Amiga Tools 4

home *** CD-ROM | disk | FTP | other *** search

/ Amiga Tools 4 / Amiga Tools 4.iso / grafix / tools / playfkiss / src / playfkiss.e < prev next >

Wrap

Text File | 1996-02-26 | 107KB | 4,553 lines

/* * * PlayFKiss: The Next Generation * * PUBLIC DOMAIN, written by Chad Randall (crandall@msen.com) * Please send comments, flames, and kiss sets! * * Feb. 1, 1996 * */ OPT LARGE OPT PREPROCESS OPT OSVERSION=37 MODULE 'dos/dos','dos/dosextens','dos/notify','dos/dosextens','dos/dosasl' MODULE 'exec/memory','exec/lists','exec/nodes' MODULE 'graphics/rastport','graphics/gfx','graphics/text','graphics/scale', 'graphics/view','graphics/gfxbase','graphics/clip','graphics/layers', 'graphics/displayinfo','graphics/regions' MODULE 'intuition/intuition','intuition/screens','intuition/gadgetclass', 'intuition/screens','intuition/pointerclass', 'intuition/classes', 'intuition/icclass','intuition/imageclass', 'intuition/cghooks' MODULE 'asl', 'libraries/asl' MODULE 'cybergraphics','cybergraphics/cybergraphics' MODULE 'datatypes', 'datatypes/datatypes','datatypes/datatypesclass','datatypes/soundclass', 'datatypes/pictureclass' MODULE 'devices/inputevent' MODULE 'keymap' MODULE 'icon' MODULE 'iffparse', 'libraries/iffparse' MODULE 'gadtools', 'libraries/gadtools' MODULE 'layers' MODULE 'rexxsyslib', 'rexx/rexxio','rexx/rxslib','rexx/errors','rexx/storage' MODULE 'utility', 'utility/tagitem','utility/date' MODULE 'xpkmaster','libraries/xpk' MODULE 'wb', 'workbench/workbench','workbench/startup' MODULE 'amigalib/lists' MODULE 'tools/easygui' MODULE 'tools/async' MODULE 'mod/pool' MODULE 'mod/lists' MODULE 'mod/filenames' MODULE 'mod/fonts' MODULE 'mod/compare' MODULE 'mod/bitmaps' MODULE 'mod/menus' MODULE 'mod/bits' MODULE 'mod/gadgets' MODULE 'mod/rexx' MODULE 'mod/ports' ENUM MAXOBJS=800,MAXOBJS_1,MAXOBJS_2 ENUM MAXCELS=1000,MAXCELS_1,MAXCELS_2 ENUM HORIZ_GID=1,VERT_GID,LEFT_GID,RIGHT_GID,UP_GID,DOWN_GID ENUM CMAP_SHOW=0,CMAP_HIDE,CMAP_GRAB ENUM MENU_NONE=0,MENU_QUIT,MENU_REDRAW,MENU_ABOUT,MENU_PREFS,MENU_CLOSE, MENU_SAVE,MENU_SAVEALL,MENU_REVEAL, MENU_OBJWIN,MENU_RESETOBJ,MENU_UNFIXOBJ,MENU_UNDO,MENU_REFIXOBJ, MENU_MOVEBACK,MENU_MOVEFORWARD, MENU_SAVESCREEN,MENU_PATROL,MENU_RESETSET, MENU_SET0,MENU_SET1,MENU_SET2,MENU_SET3,MENU_SET4, MENU_SET5,MENU_SET6,MENU_SET7,MENU_SET8,MENU_SET9, MENU_CSET0,MENU_CSET1,MENU_CSET2,MENU_CSET3,MENU_CSET4, MENU_CSET5,MENU_CSET6,MENU_CSET7,MENU_CSET8,MENU_CSET9 ENUM QUIT_NONE=0,QUIT_QUIT,QUIT_CLOSE ENUM GH_MAIN,GH_PREFS,GH_EDITOR ENUM REG_OBJ=0,REG_CEL,REG_NONE ENUM EV_UNKNOWN=0,EV_INIT,EV_BEGIN,EV_END,EV_ALARM,EV_CATCH,EV_UNFIX,EV_FIXCATCH,EV_SET,EV_DROP,EV_PRESS,EV_RELEASE,EV_FIXDROP ENUM CO_UNKNOWN=0,CO_TIMER,CO_MAP,CO_UNMAP,CO_SOUND,CO_MOVE,CO_SET,CO_ALTMAP CONST FILE_MARK_CELL=$20,FILE_MARK_PALET=$10 CONST GS1_MAX_COLOR=16,GS2_MAX_COLOR=256,GS3_MAX_COLOR=256,GS4_MAX_COLOR=256 OBJECT pi_gauge OF plugin string:PTR TO CHAR curlevel:LONG top:LONG x:INT y:INT w:INT h:INT ENDOBJECT OBJECT event ln:ln commands:lh type:LONG obj:LONG cel:PTR TO CHAR counter:LONG ENDOBJECT OBJECT command ln:ln type:LONG obj:LONG cel:PTR TO CHAR x,y:LONG sound:LONG ENDOBJECT OBJECT cel PUBLIC realname:PTR TO CHAR comment:PTR TO CHAR w:INT h:INT ox:INT oy:INT sets[11]:ARRAY buf:PTR TO CHAR obuf:PTR TO CHAR obj:INT fix:INT palet_num:CHAR mapped:CHAR bit_per_pixel:CHAR -> imbuf:PTR TO imbuf -> mask:PTR TO imbuf ENDOBJECT OBJECT obj PUBLIC number:LONG comment:PTR TO CHAR numcels:LONG fix:INT oldfix:INT lastx,lasty:INT rubx,ruby:INT x[11]:ARRAY OF INT y[11]:ARRAY OF INT ux[11]:ARRAY OF INT uy[11]:ARRAY OF INT ENDOBJECT OBJECT paleto name:PTR TO CHAR format:CHAR palet_num:CHAR bit_per_pixel:CHAR color_num:INT -> pb[10]:ARRAY OF INT color[18]:ARRAY OF LONG ENDOBJECT OBJECT listnodes;lh:lh;ENDOBJECT DEF palet[20]:ARRAY OF paleto DEF mode,palset=0 DEF animspeed=100,usebounds=FALSE,usehand=FALSE DEF tanimspeed=100,tusebounds=FALSE,tusehand=FALSE DEF useregions=REG_OBJ,tuseregions DEF usefollow=FALSE,tusefollow DEF usesnap=FALSE,tusesnap DEF usenasty=FALSE,tusenasty DEF usecgfx=FALSE DEF usewb=TRUE,tusewb,onwb=FALSE DEF usewin=FALSE,tusewin DEF objs[MAXOBJS_2]:LIST DEF cels[MAXCELS_2]:LIST DEF horizgadget:PTR TO object,vertgadget:PTR TO object DEF leftgadget:PTR TO object,rightgadget:PTR TO object DEF upgadget:PTR TO object,downgadget:PTR TO object DEF offx=0,offy=0 DEF rexxport,rexxsigbit,rexxname[150]:STRING DEF rexxhand:PTR TO rexx_handle DEF tempdir[500]:STRING DEF oldafile[500]:STRING DEF pppp:PTR TO pi_gauge DEF sizeimage:PTR TO image,leftimage:PTR TO image,rightimage:PTR TO image DEF upimage:PTR TO image,downimage:PTR TO image DEF modeid=69632,tmodeid,modename DEF screenos=0,tscreenos DEF screenas=TRUE,tscreenas DEF prefhand:PTR TO guihandle DEF sname[200]:STRING DEF apens[260]:LIST,bgpen=-1 DEF inputevent:PTR TO inputevent DEF revealpick DEF pb[12]:LIST DEF envw=640,envh=480 DEF backcolor=0 DEF fkissfound=0 DEF hand1,hand2,hand3,hand4 DEF hbm1:PTR TO bitmap,hbm2:PTR TO bitmap,hbm3:PTR TO bitmap,hbm4:PTR TO bitmap DEF linenum=1 DEF gh=0:PTR TO guihandle DEF objh=0:PTR TO guihandle,lastobj=0:PTR TO obj,lastcel=0:PTR TO cel DEF objwtext,objhtext,objftext,objmtext,objntext,objxtext,objytext DEF celntext,celnnum,celxtext,celytext,celwtext,celhtext DEF evgad,cogad,events,commands DEF win:PTR TO window DEF scr:PTR TO screen,depth DEF dri:PTR TO drawinfo DEF disp:PTR TO rastport DEF vis,cm,vp:PTR TO viewport,rp:PTR TO rastport DEF menu DEF filereq=0:PTR TO filerequester DEF ezclist:PTR TO listnodes DEF errlist:PTR TO listnodes DEF eventlist:PTR TO lh DEF temprp=0:PTR TO rastport DEF tempbitmap=0:PTR TO bitmap DEF ofilename[500]:STRING DEF smr=NIL:PTR TO screenmoderequester DEF curset=-1,curpal=0 DEF curcel:PTR TO cel,curobj:PTR TO obj,catchobj:PTR TO obj ->DEF dragbuf:PTR TO imbuf,maskbuf:PTR TO imbuf DEF dragw,dragh,olddragx,olddragy,dragox,dragoy,dragx,dragy DEF gbuf=0:PTR TO CHAR DEF region=0:PTR TO region DEF setloaded=0 DEF afname[500]:STRING DEF nobjgad,ncelgad,cellistv,cellistgad,colgad DEF errlistv,errlistgad DEF memgad,totmem=0 DEF playgad,ppgad DEF quitgad,qqgad DEF getgad,afnamegad DEF ghgetgad,ghafnamegad DEF continue,stepon DEF wx[10]:LIST,wy[10]:LIST,ww[10]:LIST,wh[10]:LIST PROC sizewin(win:PTR TO window,type) IF usewin=0 THEN RETURN -> ChangeWindowBox(win,wx[type],wy[type],ww[type],wh[type]) MoveWindow(win,wx[type]-win.leftedge,wy[type]-win.topedge) SizeWindow(win,ww[type]-win.width,wh[type]-win.height) ENDPROC PROC rememberwin(win:PTR TO window,type) IF usewin=0 THEN RETURN wx[type]:=win.leftedge wy[type]:=win.topedge ww[type]:=win.width wh[type]:=win.height ENDPROC PROC placecel(cel:PTR TO cel,x,y,ex,ey,ew,eh) DEF a1:PTR TO CHAR,a2:PTR TO CHAR DEF mod1,mod2 DEF sx,sy,dx,dy,i,t,aa,bb,cc DEF rw,rh IF (ex<0) ew:=ew+ex ex:=0 ENDIF IF (ey<0) eh:=eh+ey ey:=0 ENDIF IF ((ew+ex)>envw) ew:=envw-ex ENDIF IF ((ey+eh)>envh) eh:=envh-ey ENDIF rw:=cel.w -> Width of cel memblock to copy rh:=cel.h sx:=0 -> Top-left corner of source cel memblock sy:=0 dx:=x+cel.ox -> Top-left corner in gbuf to place cel dy:=y+cel.oy IF (dx<=ex) sx:=(ex-dx) rw:=rw-(ex-dx) dx:=ex ENDIF IF (dy<=ey) sy:=(ey-dy) rh:=rh-(ey-dy) dy:=ey ENDIF IF ((dx+rw)>=(ex+ew)) rw:=rw-((dx+rw)-(ex+ew))+1 ENDIF IF ((dy+rh)>=(ey+eh)) rh:=rh-((dy+rh)-(ey+eh))+1 ENDIF a1:=cel.buf+(cel.w*sy)+sx a2:=gbuf+(dy*envw)+dx mod1:=cel.w-rw mod2:=envw-rw rw:=rw-1 rh:=rh-1 IF ((rw>=0) AND (rh>=0)) IF ((a2>=gbuf) AND (envw>0)) IF rw>0 IF rh>0 bb:=cel.w MOVEM A0-A2/D0-D7,-(A7) -> E seems to use a few of these variables. :( MOVE.L rh,D1 -> outside loop (height) MOVE.L bb,D5 -> celwidth MOVE.L envw,D6 -> environment width MOVE.L rw,D7 -> real width to copy CLR.L D4 -> D4 is used with bytes MOVE.L a1,D2 -> these point to left side of cel,env MOVE.L a2,D3 loopt: MOVE.L D7,D0 -> inside loop (width) MOVE.L D2,A1 -> grab left side of cel,env MOVE.L D3,A2 loopi: MOVE.B (A1)+,D4 -> get source byte BEQ.S zerobyte -> if zero, skip MOVE.B D4,(A2) -> else store it zerobyte: ADDA.L #1,A2 -> inc storage pointer by one DBRA.S D0,loopi -> finish inside loop ADD.L D5,D2 -> point to one line below current ADD.L D6,D3 DBRA.S D1,loopt -> finish outside loop MOVEM (A7)+,A0-A2/D0-D7 /* THIS IS THE OLD FUNCTION, WHICH TOOK 3 TIMES AS LONG! FOR t:=0 TO rh FOR i:=0 TO rw aa:=a1[i] IF aa a2[i]:=aa ENDIF ENDFOR a1:=a1+bb a2:=a2+envw ENDFOR */ ENDIF ENDIF IF a2<gbuf DisplayBeep(0) WriteF('TRASHED MEMORY!\n') ENDIF IF a2>(gbuf+(envw*3)+(envw*envh)+1) DisplayBeep(0) WriteF('TRASHED MEMORY! \h bytes\n',(a2-(gbuf+(envw*envh)+envw))) ENDIF ELSE DisplayBeep(0) WriteF('Almost trashed with: (\d,\d)-(\d,\d) \n',dx,dy,rw,rh) ENDIF ENDIF ENDPROC PROC parseargs() DEF rdarg=0,args[10]:LIST,i DEF wb:PTR TO wbstartup /* startup message from Workbench */ DEF wbargs:PTR TO wbarg /* argument list struct. We get a passed project */ DEF wbdir[500]:STRING DEF olddir FOR i:=0 TO 9 args[i]:=0 ENDFOR IF wbmessage=NIL rdarg:=ReadArgs('FILE',args,0) IF rdarg IF args[0]<>0 StrCopy(ofilename,args[0],ALL) ENDIF ENDIF ELSE wb:=wbmessage wbargs:=wb.arglist wbargs:=wbargs+SIZEOF wbarg IF wb.numargs>1 olddir:=CurrentDir(wbargs.lock) GetCurrentDirName(wbdir,250) StrCopy(ofilename,wbdir,ALL) eaddpart(ofilename,wbargs.name,499) CurrentDir(olddir) ENDIF ENDIF ENDPROC PROC main() HANDLE DEF i,cel:PTR TO cel,tt,goon DEF dumstr[100]:STRING NEW palet[16] NEW temprp;InitRastPort(temprp) NEW eventlist;newList(eventlist) NEW inputevent loadprefs('ENV:playfkiss.prefs') FOR i:=0 TO 15;palet[i].name:=String(500);ENDFOR FOR i:=1 TO 255;apens[i]:=-1;ENDFOR;apens[0]:=0;bgpen:=-1 IF (rexxsysbase:=OpenLibrary('rexxsyslib.library',0))=NIL THEN Raise("REXL") IF (iffparsebase:=OpenLibrary('iffparse.library',37))=0 THEN Raise("IFFP") IF (keymapbase:=OpenLibrary('keymap.library',37))=0 THEN Raise("KEYM") IF (utilitybase:=OpenLibrary('utility.library',37))=0 THEN Raise("UTIL") IF (gadtoolsbase:=OpenLibrary('gadtools.library',37))=0 THEN Raise("GT") IF (aslbase:=OpenLibrary('asl.library',37))=0 THEN Raise("ASL") IF (layersbase:=OpenLibrary('layers.library',39))=0 THEN Raise("LAY") IF (datatypesbase:=OpenLibrary('datatypes.library',39))=0 THEN Raise("DT") ->WriteF('a') xpkbase:=OpenLibrary('xpkmaster.library',2) cybergfxbase:=OpenLibrary('cybergraphics.library',40) ->WriteF('b') getpointers() ->WriteF('c') region:=NewRegion() ->WriteF('d') smr:=AllocAslRequest(ASL_SCREENMODEREQUEST,[ASLSM_PUBSCREENNAME,'Workbench',ASLSM_DODEPTH,FALSE,ASLSM_DOWIDTH,FALSE,ASLSM_DOHEIGHT,FALSE,ASLSM_DOOVERSCANTYPE,TRUE,ASLSM_DOAUTOSCROLL,TRUE,NIL]) filereq:=AllocAslRequest(ASL_FILEREQUEST,[ASLFR_INITIALPATTERN,'(#?.CNF|#?.LHA|#?.LZH|#?.LZX)',NIL,NIL]) ->WriteF('e') FOR i:=0 TO MAXOBJS;objs[i]:=0;ENDFOR FOR i:=0 TO MAXCELS;cels[i]:=0;ENDFOR ->WriteF('f') StrCopy(afname,'Kiss:') StrCopy(ofilename,'Kiss:') parseargs() ->WriteF('g') goon:=QUIT_CLOSE WHILE goon=QUIT_CLOSE ->WriteF('h') setloaded:=0 IF loadcnf()=1 ->WriteF('*') IF setloaded prekiss() tempbitmap:=AllocBitMap(1024,1,8,BMF_CLEAR,scr.rastport.bitmap) temprp.bitmap:=tempbitmap ready() ->WriteF('`') goon:=playkiss() postkiss() ENDIF ELSE goon:=QUIT_QUIT ENDIF IF StrLen(afname) splitname(afname,ofilename,dumstr) ENDIF IF (StrLen(ofilename)>0) THEN StrAdd(ofilename,'/') ENDWHILE EXCEPT DO SELECT exception CASE 0;NOP CASE "REXL";err('Missing rexxsyslib.library') CASE "KEYM";err('Missing keymap.library') CASE "UTIL";err('Missing utility.library') CASE "GT";err('Missing gadtools.library') CASE "ASL";err('Missing asl.library') CASE "LAY";err('Missing layers.library') CASE "DT";err('Missing datatype.library') CASE "IFFP";err('Missing iffparse.library') CASE "MEM";err('Not enough memory.') CASE "Egui";err('EasyGUI error.') CASE "bigg";err('EasyGUI too big!') CASE "SCR";err('Can\at open screen.') CASE "WIN";err('Can\at open window.') CASE "MENU";err('Can\at create menu.') CASE "VIS";err('Can\t obtain visual structure.') CASE "file";err('File error.') CASE "err";err('Misc. error?') ENDSELECT ->WriteF('1') postkiss() ->WriteF('2') freepointers() ->WriteF('3') freecels() ->WriteF('4') freeobjs() ->WriteF('5') freepals() ->WriteF('6') freeevents() ->WriteF('7') IF region THEN DisposeRegion(region) ->WriteF('8') IF smr THEN FreeAslRequest(smr) IF filereq THEN FreeAslRequest(filereq) savewinpos() IF tempbitmap THEN FreeBitMap(tempbitmap) IF rexxsysbase THEN CloseLibrary(rexxsysbase) IF iffparsebase THEN CloseLibrary(iffparsebase) IF keymapbase THEN CloseLibrary(keymapbase) IF utilitybase THEN CloseLibrary(utilitybase) IF gadtoolsbase THEN CloseLibrary(gadtoolsbase) IF aslbase THEN CloseLibrary(aslbase) IF layersbase THEN CloseLibrary(layersbase) IF datatypesbase THEN CloseLibrary(datatypesbase) IF xpkbase THEN CloseLibrary(xpkbase) IF cybergfxbase THEN CloseLibrary(cybergfxbase) ENDPROC PROC getpointers() NEW hbm1,hbm2,hbm3,hbm4 hbm1.bytesperrow:=2 hbm1.rows:=15 hbm1.depth:=2 hbm1.planes[0]:={hand1dataa} hbm1.planes[1]:={hand1datab} hbm2.bytesperrow:=2 hbm2.rows:=15 hbm2.depth:=2 hbm2.planes[0]:={hand2dataa} hbm2.planes[1]:={hand2datab} hbm3.bytesperrow:=2 hbm3.rows:=1 hbm3.depth:=2 hbm3.planes[0]:={hand3dataa} hbm3.planes[1]:={hand3datab} hbm4.bytesperrow:=2 hbm4.rows:=15 hbm4.depth:=2 hbm4.planes[0]:={hand4dataa} hbm4.planes[1]:={hand4datab} hand1:=NewObjectA(NIL,'pointerclass',[POINTERA_BITMAP,hbm1, POINTERA_XOFFSET,-1, POINTERA_YOFFSET,-1, POINTERA_XRESOLUTION,POINTERXRESN_SCREENRES, POINTERA_YRESOLUTION,POINTERYRESN_SCREENRESASPECT, NIL,NIL]) hand2:=NewObjectA(NIL,'pointerclass',[POINTERA_BITMAP,hbm2, POINTERA_XOFFSET,-3, POINTERA_YOFFSET,-3, POINTERA_XRESOLUTION,POINTERXRESN_SCREENRES, POINTERA_YRESOLUTION,POINTERYRESN_SCREENRESASPECT, NIL,NIL]) hand3:=NewObjectA(NIL,'pointerclass',[POINTERA_BITMAP,hbm3, POINTERA_XRESOLUTION,POINTERXRESN_HIRES, POINTERA_YRESOLUTION,POINTERYRESN_HIGH, POINTERA_XOFFSET,0, POINTERA_YOFFSET,0, NIL,NIL]) hand4:=NewObjectA(NIL,'pointerclass',[POINTERA_BITMAP,hbm4, POINTERA_XRESOLUTION,POINTERXRESN_SCREENRES, POINTERA_YRESOLUTION,POINTERYRESN_SCREENRESASPECT, POINTERA_XOFFSET,-6, POINTERA_YOFFSET,-6, NIL,NIL]) ENDPROC PROC freepointers() IF hand1 THEN DisposeObject(hand1) IF hand2 THEN DisposeObject(hand2) IF hand3 THEN DisposeObject(hand3) IF hand4 THEN DisposeObject(hand4) ENDPROC PROC changeset(newset) DEF ev=0 IF (curset=newset) THEN RETURN ev:=findeventtype(EV_SET,newset) curset:=newset changepal(pb[curset]) IF ev runcommands(ev) ENDIF check(menu,MENU_SET0,FALSE) check(menu,MENU_SET1,FALSE) check(menu,MENU_SET2,FALSE) check(menu,MENU_SET3,FALSE) check(menu,MENU_SET4,FALSE) check(menu,MENU_SET5,FALSE) check(menu,MENU_SET6,FALSE) check(menu,MENU_SET7,FALSE) check(menu,MENU_SET8,FALSE) check(menu,MENU_SET9,FALSE) SELECT curset CASE 0;check(menu,MENU_SET0,TRUE) CASE 1;check(menu,MENU_SET1,TRUE) CASE 2;check(menu,MENU_SET2,TRUE) CASE 3;check(menu,MENU_SET3,TRUE) CASE 4;check(menu,MENU_SET4,TRUE) CASE 5;check(menu,MENU_SET5,TRUE) CASE 6;check(menu,MENU_SET6,TRUE) CASE 7;check(menu,MENU_SET7,TRUE) CASE 8;check(menu,MENU_SET8,TRUE) CASE 9;check(menu,MENU_SET9,TRUE) ENDSELECT ENDPROC PROC changepal(newpal) check(menu,MENU_CSET0,FALSE) check(menu,MENU_CSET1,FALSE) check(menu,MENU_CSET2,FALSE) check(menu,MENU_CSET3,FALSE) check(menu,MENU_CSET4,FALSE) check(menu,MENU_CSET5,FALSE) check(menu,MENU_CSET6,FALSE) check(menu,MENU_CSET7,FALSE) check(menu,MENU_CSET8,FALSE) check(menu,MENU_CSET9,FALSE) curpal:=limit(newpal,0,9) SELECT curpal CASE 0;check(menu,MENU_CSET0,TRUE) CASE 1;check(menu,MENU_CSET1,TRUE) CASE 2;check(menu,MENU_CSET2,TRUE) CASE 3;check(menu,MENU_CSET3,TRUE) CASE 4;check(menu,MENU_CSET4,TRUE) CASE 5;check(menu,MENU_CSET5,TRUE) CASE 6;check(menu,MENU_CSET6,TRUE) CASE 7;check(menu,MENU_CSET7,TRUE) CASE 8;check(menu,MENU_CSET8,TRUE) CASE 9;check(menu,MENU_CSET9,TRUE) ENDSELECT updatecolors() ENDPROC PROC moveback() -> celnum:=celnul-1 DEF cn=-1,i DEF cel:PTR TO cel DEF swapcel:PTR TO cel IF ((lastcel<>0) AND (lastobj<>0)) FOR i:=0 TO MAXCELS cel:=cels[i] IF cel=lastcel cn:=i ENDIF ENDFOR ENDIF IF (cn>0) swapcel:=cels[cn-1] IF swapcel i:=cels[cn-1] cels[cn-1]:=cels[cn] cels[cn]:=i prechange() orcel(lastcel,lastobj) postchange() updateobjwin() ENDIF ENDIF ENDPROC PROC moveforward() -> celnum:=celnum+1 DEF cn=-1,i DEF cel:PTR TO cel DEF swapcel:PTR TO cel prechange() IF ((lastcel<>0) AND (lastobj<>0)) FOR i:=0 TO MAXCELS cel:=cels[i] IF cel=lastcel cn:=i ENDIF ENDFOR ENDIF IF ((cn>-1) AND (cn<MAXCELS)) swapcel:=cels[cn+1] IF swapcel i:=cels[cn+1] cels[cn+1]:=cels[cn] cels[cn]:=i prechange() orcel(lastcel,lastobj) postchange() updateobjwin() ENDIF ENDIF ENDPROC PROC hidecel() IF lastcel lastcel.setset(curset,0) prechange() orcel(lastcel,lastobj) postchange() updateobjwin() ENDIF ENDPROC PROC openobjwin() IF objh THEN RETURN objh:=guiinit('Editor', [ROWS, [COLS, [BEVELR, [ROWS, [COLS, [EQROWS, objntext:=[NUM,MAXOBJS,'Obj:',0,1], objwtext:=[NUM,1024,'Width:',0,1], objxtext:=[NUM,1024,'X:',0,1], [SBUTTON,{resetcur},'Reset'] ], [EQROWS, objmtext:=[NUM,1024,'Cels:',0,1], objhtext:=[NUM,1024,'Height:',0,1], objytext:=[NUM,1024,'Y:',0,1], [SBUTTON,{undo},'Undo'] ] ], [BAR], [ROWS, [COLS, objftext:=[INTEGER,{setslidefix},'Fix:',327680,5], [BUTTON,{storefixcur},'Store'] ], [EQCOLS, [SBUTTON,{resetfixcur},'Reset'], [SBUTTON,{unfixcur},'Unfix'] ] ] ] ], [BEVELR, [ROWS, celnnum:=[NUM,MAXCELS,'Cel:',0,1], celntext:=[TEXT,'NONAMEYET.CEL','Name:',FALSE,1], [COLS, [EQROWS, celxtext:=[NUM,1024,'OffsetX:',0,1], [SPACEH], celwtext:=[NUM,1024,'Width:',0,1] ], [EQROWS, celytext:=[NUM,1024,'OffsetY:',0,1], [SPACEH], celhtext:=[NUM,1024,'Height:',0,1] ] ], [BAR], [EQCOLS, [BUTTON,{moveback},'Back'], [BUTTON,{moveforward},'Forward'], [BUTTON,{hidecel},'Hide'] ] ] ] ] ] ,0,scr) sizewin(objh.wnd,GH_EDITOR) updateobjwin() ENDPROC PROC setslidefix(a,val) IF (lastobj) lastobj.setfix(val) ENDIF ENDPROC PROC updateobjwin() DEF w=0,h=0,i,cel:PTR TO cel,obj:PTR TO obj DEF cn=-1 IF objh IF ((lastobj<>0) AND (lastcel<>0)) FOR i:=0 TO MAXCELS cel:=cels[i] IF cel IF (cel=lastcel) cn:=MAXCELS-i ENDIF ENDIF ENDFOR setnum(objh,objwtext,lastobj.width()) setnum(objh,objhtext,lastobj.height()) setnum(objh,objmtext,lastobj.countmembers()) setinteger(objh,objftext,lastobj.fix) setnum(objh,objntext,lastobj.number) setnum(objh,objxtext,lastobj.x[curset]) setnum(objh,objytext,lastobj.y[curset]) setnum(objh,celnnum,cn) settext(objh,celntext,lastcel.realname) setnum(objh,celxtext,lastcel.ox) setnum(objh,celytext,lastcel.oy) setnum(objh,celwtext,lastcel.w) setnum(objh,celhtext,lastcel.h) ELSE setnum(objh,objwtext,-1) setnum(objh,objhtext,-1) setnum(objh,objmtext,-1) setinteger(objh,objftext,0) setnum(objh,objntext,-1) setnum(objh,objxtext,-1) setnum(objh,objytext,-1) setnum(objh,celnnum,-1) settext(objh,celntext,'N/A') setnum(objh,celxtext,-1) setnum(objh,celytext,-1) setnum(objh,celwtext,-1) setnum(objh,celhtext,-1) ENDIF ENDIF ENDPROC PROC prekiss() DEF res=0 openscr() ENDPROC res PROC revealp(a,val) revealpick:=val ENDPROC PROC reveal() DEF lh:PTR TO listnodes DEF i,cel:PTR TO cel,obj:PTR TO obj DEF str[500]:STRING DEF rgh DEF actual=-1,ii=-1 NEW lh.new() FOR i:=0 TO MAXCELS cel:=cels[i] IF cel IF cel.sets[curset]=0 StringF(str,'#\d[4] "\s"',MAXCELS-i,cel.realname) lh.add(str) ENDIF ENDIF ENDFOR IF isempty(lh.head())=0 revealpick:=-1 rgh:=easygui('Reveal which cel?', [ROWS, [LISTV,{revealp},0,16,8,lh.head(),FALSE,1,0], [EQCOLS, [SBUTTON,2,'Ok'], [SBUTTON,0,'Cancel'] ] ],0,scr) IF (rgh>0) AND (revealpick>-1) FOR i:=0 TO MAXCELS cel:=cels[i] IF cel IF cel.sets[curset]=0 actual:=actual+1 IF (actual=revealpick) ii:=i ENDIF ENDIF ENDIF ENDFOR IF ii>-1 cel:=cels[ii] IF cel obj:=objs[cel.obj] IF obj cel.setset(curset,1) prechange() orcel(cel,obj) postchange() updateobjwin() ENDIF ENDIF ENDIF ENDIF ENDIF END lh ENDPROC PROC playkiss() DEF i,cel:PTR TO cel,obj:PTR TO obj DEF mes:PTR TO intuimessage,quit=QUIT_NONE DEF class,code,item:PTR TO menuitem DEF select DEF ev=0,rrre DEF minx,miny DEF sig,oldtop,w,h curset:=-1 lastcel:=0;lastobj:=0;curobj:=0;curcel:=0;catchobj:=0 runevent(EV_INIT,0,0) runevent(EV_BEGIN,0,0) changeset(0) rrre:=-1 WHILE quit=QUIT_NONE sig:=Wait(-1) IF (sig AND SIGBREAKF_CTRL_C) THEN quit:=QUIT_QUIT IF objh rrre:=guimessage(objh) IF rrre>=0 rememberwin(objh.wnd,GH_EDITOR) cleangui(objh) objh:=0 ENDIF ENDIF WHILE (mes:=GetMsg(win.userport)) class:=mes.class SELECT class CASE IDCMP_CLOSEWINDOW quit:=QUIT_QUIT CASE IDCMP_NEWSIZE updatescroll() CASE IDCMP_IDCMPUPDATE code:=GetTagData(GA_ID,0,mes.iaddress) SELECT code CASE HORIZ_GID updatescroll() CASE VERT_GID updatescroll() CASE LEFT_GID GetAttr(PGA_TOP,horizgadget,{oldtop}) w:=recalchvisible() h:=recalcvvisible() IF oldtop>0 updateprop(horizgadget,PGA_TOP,oldtop-1) GetAttr(PGA_TOP,horizgadget,{offx}) updatelistbuffered(offx,offy,w,h) ENDIF CASE RIGHT_GID GetAttr(PGA_TOP,horizgadget,{oldtop}) w:=recalchvisible() h:=recalcvvisible() IF oldtop<(envw-w) updateprop(horizgadget,PGA_TOP,oldtop+1) GetAttr(PGA_TOP,horizgadget,{offx}) updatelistbuffered(offx,offy,w,h) ENDIF CASE UP_GID GetAttr(PGA_TOP,vertgadget,{oldtop}) w:=recalchvisible() h:=recalcvvisible() IF oldtop>0 updateprop(vertgadget,PGA_TOP,oldtop-1) GetAttr(PGA_TOP,vertgadget,{offy}) updatelistbuffered(offx,offy,w,h) ENDIF CASE DOWN_GID GetAttr(PGA_TOP,vertgadget,{oldtop}) w:=recalchvisible() h:=recalcvvisible() IF oldtop<(envh-h) updateprop(vertgadget,PGA_TOP,oldtop+1) GetAttr(PGA_TOP,vertgadget,{offy}) updatelistbuffered(offx,offy,w,h) ENDIF ENDSELECT CASE IDCMP_MENUVERIFY ClearPointer(win) dropobj(olddragx+dragox,olddragy+dragoy) CASE IDCMP_MENUPICK code:=mes.code WHILE code<>MENUNULL IF (item:=ItemAddress(menu,code)) select:=Long(item+34) SELECT select CASE MENU_ABOUT aboutme() CASE MENU_REDRAW updatelist() CASE MENU_QUIT quit:=QUIT_QUIT CASE MENU_PREFS prefs() CASE MENU_OBJWIN IF objh=0 openobjwin() ELSE rememberwin(objh.wnd,GH_EDITOR) cleangui(objh);objh:=0 ENDIF CASE MENU_CLOSE;quit:=QUIT_CLOSE CASE MENU_SET0;changeset(0) CASE MENU_SET1;changeset(1) CASE MENU_SET2;changeset(2) CASE MENU_SET3;changeset(3) CASE MENU_SET4;changeset(4) CASE MENU_SET5;changeset(5) CASE MENU_SET6;changeset(6) CASE MENU_SET7;changeset(7) CASE MENU_SET8;changeset(8) CASE MENU_SET9;changeset(9) CASE MENU_CSET0;changepal(0) CASE MENU_CSET1;changepal(1) CASE MENU_CSET2;changepal(2) CASE MENU_CSET3;changepal(3) CASE MENU_CSET4;changepal(4) CASE MENU_CSET5;changepal(5) CASE MENU_CSET6;changepal(6) CASE MENU_CSET7;changepal(7) CASE MENU_CSET8;changepal(8) CASE MENU_CSET9;changepal(9) CASE MENU_RESETOBJ;resetcur() CASE MENU_UNFIXOBJ;unfixcur() CASE MENU_REFIXOBJ;refixcur() CASE MENU_UNDO;undo() CASE MENU_SAVE;appendcoords(afname) CASE MENU_SAVEALL;saveall(afname) CASE MENU_REVEAL;reveal() CASE MENU_MOVEBACK;moveback() CASE MENU_MOVEFORWARD;moveforward() CASE MENU_SAVESCREEN;savescreen(afname) CASE MENU_PATROL;patrol() CASE MENU_RESETSET;resetset() ENDSELECT code:=item.nextselect ELSE code:=MENUNULL ENDIF ENDWHILE handme() CASE IDCMP_VANILLAKEY select:=mes.code SELECT select CASE "0";changepal(0) CASE "1";changepal(1) CASE "2";changepal(2) CASE "3";changepal(3) CASE "4";changepal(4) CASE "5";changepal(5) CASE "6";changepal(6) CASE "7";changepal(7) CASE "8";changepal(8) CASE "9";changepal(9) CASE 27;quit:=QUIT_QUIT CASE "-";moveback() CASE "=";moveforward() CASE "+";moveforward() CASE "f";unfixcur() CASE "F";refixcur() CASE "u";undo() CASE "w" IF objh=0 openobjwin() ELSE rememberwin(objh.wnd,GH_EDITOR) cleangui(objh);objh:=0 ENDIF ENDSELECT -> WriteF('V \d \h\n',mes.code,mes.code) CASE IDCMP_RAWKEY select:=mes.code SELECT select CASE 80;changeset(0) CASE 81;changeset(1) CASE 82;changeset(2) CASE 83;changeset(3) CASE 84;changeset(4) CASE 85;changeset(5) CASE 86;changeset(6) CASE 87;changeset(7) CASE 88;changeset(8) CASE 89;changeset(9) ENDSELECT -> WriteF('R \d \h\n',mes.code,mes.code) CASE IDCMP_MOUSEBUTTONS IF mes.code=MENUDOWN noreportmousemoves(win) dropobj(olddragx+dragox,olddragy+dragoy) ENDIF IF mes.code=SELECTUP noreportmousemoves(win) handme() dropobj(mes.mousex,mes.mousey) ENDIF IF mes.code=SELECTDOWN cel,obj:=findobj(mes.mousex-win.borderleft+offx,mes.mousey-win.bordertop+offy) IF obj>=0 lastobj:=obj lastcel:=cel lastobj.remember(curset) ENDIF curobj:=0 curcel:=0 catchobj:=0 IF ((cel>=0) AND (obj>=0)) IF obj.fix=1 obj.setfix(0) ELSE IF (obj.fix>1) obj.setfix(bigger(obj.fix-1,0)) IF (obj.fix<(obj.oldfix-1)) THEN IF (runevent(EV_FIXCATCH,obj,cel)) THEN catchobj:=obj SetWindowPointerA(win,[WA_POINTER,hand4,WA_POINTERDELAY,FALSE,NIL,NIL]) ENDIF ENDIF IF (runevent(EV_PRESS,obj,cel)) THEN catchobj:=obj IF ((obj.fix<=0) OR ((usesnap<>FALSE) AND (obj.fix<6))) IF obj.fix=0 IF (runevent(EV_CATCH,obj,cel)) THEN catchobj:=obj ENDIF curobj:=obj;curcel:=cel dragx:=obj.x[curset] dragy:=obj.y[curset] olddragx:=dragx olddragy:=dragy dragox:=mes.mousex-dragx dragoy:=mes.mousey-dragy reportmousemoves(win) grabme() pickupobj() ENDIF ENDIF updateobjwin() ENDIF CASE IDCMP_INTUITICKS IF curobj=0 dectimers() ELSE curobj.move((IF usefollow THEN mes.mousex ELSE win.mousex)-dragox,(IF usefollow THEN mes.mousey ELSE win.mousey)-dragoy,TRUE) ENDIF CASE IDCMP_MOUSEMOVE IF curobj curobj.move((IF usefollow THEN mes.mousex ELSE win.mousex)-dragox,(IF usefollow THEN mes.mousey ELSE win.mousey)-dragoy,TRUE) ENDIF ENDSELECT ReplyMsg(mes) ENDWHILE ENDWHILE IF objh rememberwin(objh.wnd,GH_EDITOR) cleangui(objh);objh:=0 ENDIF runevent(EV_END,0,0) ENDPROC quit PROC patrol() DEF i,obj:PTR TO obj,eb eb:=usebounds usebounds:=TRUE busy() prechange() FOR i:=0 TO MAXOBJS obj:=objs[i] IF obj obj.movequick(obj.x[curset],obj.y[curset]) ENDIF ENDFOR postchange() ready() usebounds:=eb ENDPROC PROC resetset() DEF i,obj:PTR TO obj,eb eb:=EasyRequestArgs(win,[20,0,'RESET ALL DATA','Selecting "Proceed" will loose all changes.', 'Proceed|Cancel'],0,0) IF eb busy() prechange() FOR i:=0 TO MAXOBJS obj:=objs[i] IF obj obj.movequick(obj.ux[curset],obj.uy[curset]) obj.setfix(obj.oldfix) ENDIF ENDFOR postchange() ready() ENDIF ENDPROC PROC unfixcur() IF lastobj lastobj.setfix(0) updateobjwin() ENDIF ENDPROC PROC refixcur() IS resetfixcur() PROC storefixcur() IF lastobj lastobj.oldfix:=lastobj.fix updateobjwin() ENDIF ENDPROC PROC resetfixcur() IF lastobj lastobj.setfix(lastobj.oldfix) updateobjwin() ENDIF ENDPROC PROC resetcur() IF lastobj lastobj.remember(curset) lastobj.forcemove(lastobj.ux[curset],lastobj.uy[curset],TRUE) ENDIF ENDPROC PROC pickupobj() DEF cel:PTR TO cel DEF obj:PTR TO obj DEF ev,i IF curobj prechange() curobj.remember(curset) FOR i:=0 TO MAXCELS cel:=cels[i] IF cel IF cel.sets[curset] IF (cel.obj>=0) obj:=objs[cel.obj] IF (obj) IF (obj=curobj) IF cel.mapped=CMAP_SHOW cel.mapped:=CMAP_GRAB ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDFOR ENDIF ENDPROC PROC dropobj(x,y) DEF cel:PTR TO cel DEF obj:PTR TO obj DEF ev,i IF curobj prechange() runevent(EV_RELEASE,curobj,curcel) IF curobj.fix=0 runevent(EV_DROP,curobj,curcel) ELSE runevent(EV_FIXDROP,curobj,curcel) ENDIF IF curobj.fix>0 curobj.move(curobj.rubx,curobj.ruby,FALSE) ELSE curobj.move(x-dragox,y-dragoy,FALSE) ENDIF FOR i:=0 TO MAXCELS cel:=cels[i] IF cel IF (cel.obj>=0) obj:=objs[cel.obj] IF (obj) IF (obj=curobj) IF cel.mapped<>CMAP_HIDE cel.mapped:=CMAP_SHOW ENDIF ENDIF ENDIF ENDIF ENDIF ENDFOR postchange() IF (catchobj=curobj) THEN catchobj:=0 curobj:=0 curcel:=0 dragox:=0 dragoy:=0 ENDIF IF catchobj runevent(EV_RELEASE,catchobj,cel) IF catchobj.fix=0 runevent(EV_DROP,catchobj,cel) ELSE runevent(EV_FIXDROP,catchobj,cel) ENDIF catchobj:=0 ENDIF updateobjwin() ENDPROC PROC undo() DEF x,y IF (lastobj<>0) lastobj.undo() ENDIF ENDPROC PROC findobj(x,y) DEF i DEF obj:PTR TO obj,cel:PTR TO cel FOR i:=MAXCELS TO 0 STEP -1 cel:=cels[i] IF cel IF (cel.sets[curset]) IF (cel.mapped=CMAP_SHOW) IF cel.buf obj:=objs[cel.obj] IF obj IF x>=(obj.x[curset]+cel.ox) IF y>=(obj.y[curset]+cel.oy) IF x<(obj.x[curset]+cel.ox+cel.w) IF y<(obj.y[curset]+cel.oy+cel.h) IF cel.buf[(x-(obj.x[curset]+cel.ox))+((y-(obj.y[curset]+cel.oy))*cel.w)] -> IF ReadPixel(cel.mask.rast,x-(obj.x[curset]+cel.ox),y-(obj.y[curset]+cel.oy)) RETURN cel,obj ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDFOR ENDPROC -1,-1 PROC altmapcel(nu) DEF cel:PTR TO cel cel:=cels[nu] IF cel IF cel.mapped=CMAP_SHOW cel.mapped:=CMAP_HIDE erasecel(cel) ELSE cel.mapped:=CMAP_SHOW drawcel(cel,nu) ENDIF ENDIF ENDPROC PROC mapcel(nu) DEF cel:PTR TO cel cel:=cels[nu] IF cel IF cel.mapped<>CMAP_SHOW cel.mapped:=CMAP_SHOW drawcel(cel,nu) ENDIF ENDIF ENDPROC PROC unmapcel(nu) DEF cel:PTR TO cel cel:=cels[nu] IF cel IF cel.mapped<>CMAP_HIDE cel.mapped:=CMAP_HIDE erasecel(cel) ENDIF ENDIF ENDPROC PROC prechange() ClearRegion(region) /* globx1:=60000 globy1:=60000 globx2:=0 globy2:=0*/ ENDPROC PROC postchange() DEF cregion:PTR TO regionrectangle DEF x1,y1,minx1=60000,miny1=60000,maxx1=0,maxy1=0 DEF bounds:PTR TO rectangle cregion:=region.regionrectangle IF region.bounds x1:=region.bounds.minx y1:=region.bounds.miny WHILE cregion bounds:=cregion.bounds IF (useregions<>REG_NONE) updatelistbuffered(x1+bounds.minx,y1+bounds.miny,bounds.maxx-bounds.minx+1,bounds.maxy-bounds.miny+1,TRUE) ELSE minx1:=smaller(minx1,x1+bounds.minx) miny1:=smaller(miny1,y1+bounds.miny) maxx1:=bigger(maxx1,x1+bounds.maxx) maxy1:=bigger(maxy1,y1+bounds.maxy) ENDIF cregion:=cregion.next ENDWHILE ClearRegion(region) IF (useregions=REG_NONE) updatelistbuffered(minx1,miny1,maxx1-minx1+1,maxy1-miny1+1,TRUE) ENDIF ELSE WriteF('Empty region?!?\n');DisplayBeep(0) ENDIF ENDPROC PROC orcel(cel:PTR TO cel,obj:PTR TO obj,flag=FALSE) IF obj IF cel IF ((flag<>FALSE) AND (useregions=REG_OBJ)) OrRectRegion(region,[obj.x[curset],obj.y[curset],obj.x[curset]+obj.width(),obj.y[curset]+obj.height()]:rectangle) ELSE OrRectRegion(region,[obj.x[curset]+cel.ox,obj.y[curset]+cel.oy,obj.x[curset]+cel.ox+cel.w,obj.y[curset]+cel.oy+cel.h]:rectangle) ENDIF ENDIF ENDIF ENDPROC PROC erasecel(cel:PTR TO cel) DEF obj:PTR TO obj IF cel=0;WriteF('zerocel!\n');RETURN;ENDIF obj:=objs[cel.obj] IF obj orcel(cel,obj) ENDIF ENDPROC PROC drawcel(cel:PTR TO cel,nu) DEF obj:PTR TO obj IF cel=0;WriteF('zerocel!\n');RETURN;ENDIF obj:=objs[cel.obj] IF obj orcel(cel,obj) ENDIF ENDPROC PROC updatelistbuffered(x,y,w,h,flag=FALSE) HANDLE DEF cel:PTR TO cel,obj:PTR TO obj DEF obx,oby DEF qox,qoy DEF t,a,i,yy,xx DEF ds1:PTR TO datestamp DEF ds2:PTR TO datestamp DEF ds3:PTR TO datestamp ->WriteF('buffer-(\dx\d)-(\dx\d) \n',x,y,w,h) IF (x<0) w:=w+x x:=0 ENDIF IF (y<0) h:=h+y y:=0 ENDIF IF ((w+x)>envw) w:=envw-x ENDIF IF ((y+h)>envh) h:=envh-y ENDIF IF ((w>0) AND (h>0)) xx:=x+w-1 yy:=y+h-1 IF onwb FOR t:=y TO yy a:=(envw*t)+x FOR i:=x TO xx gbuf[a]:=bgpen;a:=a+1 ENDFOR ENDFOR ELSE FOR t:=y TO yy a:=(envw*t)+x FOR i:=x TO xx gbuf[a]:=0;a:=a+1 ENDFOR ENDFOR ENDIF FOR i:=0 TO MAXCELS cel:=cels[i] IF (cel) IF (cel.sets[curset]) IF (cel.buf) IF ((cel.mapped=CMAP_SHOW) OR ((cel.mapped=CMAP_GRAB) AND (flag<>0))) obj:=objs[cel.obj] IF (obj) obx:=obj.x[curset] oby:=obj.y[curset] qox:=cel.ox qoy:=cel.oy IF ((qox+obx)<=(x+w-1)) IF ((qoy+oby)<=(y+h-1)) IF ((qox+obx+cel.w-1)>=x) IF ((qoy+oby+cel.h-1)>=y) placecel(cel,obx,oby,x,y,w,h) ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDFOR IF ((usenasty<>0) AND (usecgfx<>0)) WritePixelArray(gbuf,x-offx,y-offy,envw,rp,x,y,w,h,RECTFMT_LUT8) ELSE t:=gbuf+(y*envw)+x xx:=x-offx FOR i:=y TO y+h-1 WritePixelLine8(rp,xx,i-offy,w,t,temprp) t:=t+envw ENDFOR ENDIF ENDIF EXCEPT WriteF('No memory!\n') updatelist() ENDPROC PROC updatelist(off=0,flag=TRUE) DEF i:REG,cel:PTR TO cel,obj:PTR TO obj,t:REG,a:REG a:=0 busy() IF onwb FOR t:=0 TO envh-1 FOR i:=0 TO envw-1 gbuf[a]:=bgpen;a:=a+1 ENDFOR ENDFOR ELSE FOR t:=0 TO envh-1 FOR i:=0 TO envw-1 gbuf[a]:=0;a:=a+1 ENDFOR ENDFOR ENDIF FOR i:=off TO MAXCELS cel:=cels[i] IF cel IF cel.buf IF cel.mapped=CMAP_SHOW OR ((cel.mapped=CMAP_GRAB) AND (flag<>0)) IF cel.sets[curset] obj:=objs[cel.obj] IF obj placecel(cel,obj.x[curset],obj.y[curset],0,0,envw,envh) ENDIF ENDIF ENDIF ENDIF ENDIF ENDFOR IF ((usenasty<>0) AND (usecgfx<>0)) WritePixelArray(gbuf,0-offx,0-offy,envw,rp,0,0,envw,envh,RECTFMT_LUT8) ELSE FOR i:=0 TO envh-1 WritePixelLine8(rp,0-offx,i-offy,envw,gbuf+(i*envw),temprp) ENDFOR ENDIF ready() ENDPROC PROC unmapobj(objn) DEF obj:PTR TO obj,cel:PTR TO cel,i obj:=objs[objn] IF obj FOR i:=0 TO MAXCELS cel:=cels[i] IF cel IF cel.obj=objn cel.mapped:=CMAP_HIDE ENDIF ENDIF ENDFOR updateobj(obj,objn) ENDIF ENDPROC PROC mapobj(objn) DEF obj:PTR TO obj,cel:PTR TO cel,i obj:=objs[objn] IF obj FOR i:=0 TO MAXCELS cel:=cels[i] IF cel IF cel.obj=objn cel.mapped:=CMAP_SHOW ENDIF ENDIF ENDFOR updateobj(obj,objn) ENDIF ENDPROC PROC altmapobj(objn) DEF obj:PTR TO obj,cel:PTR TO cel,i FOR i:=0 TO MAXCELS cel:=cels[i] IF cel IF cel.obj=objn altmapcel(i) /* obj:=objs[cel.obj] IF obj IF cel.mapped=CMAP_HIDE mapcel(i) ELSE unmapcel(i) ENDIF i:=MAXCELS_2 ENDIF */ ENDIF ENDIF ENDFOR ENDPROC PROC updateobj(obj:PTR TO obj,objn) DEF cel:PTR TO cel DEF i DEF x=60000,y=60000,w=0,h=0 IF obj FOR i:=0 TO MAXCELS cel:=cels[i] IF cel IF cel.obj=objn IF cel.sets[curset] orcel(cel,obj,TRUE) ENDIF ENDIF ENDIF ENDFOR ENDIF ENDPROC PROC playsound(co:PTR TO command) IF co.sound DoDTMethodA(co.sound,NIL,NIL,[DTM_TRIGGER,NIL,STM_PLAY,NIL]) ENDIF ENDPROC PROC runcommands(ev:PTR TO event) DEF co:PTR TO command,oldco DEF next2 DEF type,cel,cel2 DEF newev:PTR TO event DEF co2:PTR TO command DEF obj:PTR TO obj prechange() co:=ev.commands.head REPEAT next2:=co.ln.succ IF (next2) type:=co.type SELECT type CASE CO_SOUND playsound(co) CASE CO_UNMAP ->WriteF('-') IF co.obj=-1 cel:=findnamedcel(co.cel) IF cel>-1 unmapcel(cel) ENDIF ELSE unmapobj(co.obj) ENDIF CASE CO_MAP ->WriteF('+') IF co.obj=-1 cel:=findnamedcel(co.cel) IF cel>-1 mapcel(cel) ENDIF ELSE mapobj(co.obj) ENDIF CASE CO_ALTMAP ->WriteF('A') IF co.obj=-1 cel:=findnamedcel(co.cel) IF cel>-1 altmapcel(cel) ENDIF ELSE altmapobj(co.obj) ENDIF CASE CO_TIMER ->WriteF('T') newev:=findeventtype(EV_ALARM,co.x) IF newev newev.counter:=co.y ENDIF CASE CO_MOVE IF co.obj=-1 cel:=findnamedcel(co.cel) IF cel>-1 -> movecel(cel) ENDIF ELSE obj:=objs[co.obj] IF ((obj<>0) AND (curobj=0)) dragox:=0;dragoy:=0 obj.forcemove(obj.x[curset]+co.x,obj.y[curset]+co.y,FALSE) ENDIF ENDIF ENDSELECT ENDIF co:=next2 UNTIL next2=0 postchange() ENDPROC PROC dectimers() DEF ev:PTR TO event DEF next1 ev:=eventlist REPEAT next1:=ev.ln.succ IF (next1) IF ev.type=EV_ALARM IF ev.counter>0 ev.counter:=bigger(ev.counter-animspeed,0) IF ev.counter=0 runcommands(ev) ENDIF ENDIF ENDIF ENDIF ev:=next1 UNTIL next1=0 ENDPROC PROC postkiss() closescr() ENDPROC PROC updatecolors() DEF i,pn=0,t DEF uf:PTR TO LONG DEF cel:PTR TO cel DEF r,g,b,p IF onwb busy() FOR i:=1 TO 255 IF apens[i]>=0 ReleasePen(cm,apens[i]) apens[i]:=-1 ENDIF ENDFOR IF (bgpen>=0) THEN ReleasePen(cm,bgpen);bgpen:=-1 FOR i:=0 TO 15 IF (palet[i].color[curpal]<>0) FOR t:=0 TO (palet[i].color_num-1) r:=(Long(palet[i].color[curpal]+(t*12))) g:=(Long(palet[i].color[curpal]+(t*12)+4)) b:=(Long(palet[i].color[curpal]+(t*12)+8)) IF pn>0 apens[pn]:=ObtainBestPenA(cm,r,g,b,[OBP_PRECISION,PRECISION_EXACT]) IF apens[pn]=0 REPEAT IF apens[pn]>=0 THEN ReleasePen(cm,apens[pn]) r:=r+$01010101 g:=g+$01010101 b:=b+$01010101 apens[pn]:=ObtainBestPenA(cm,r,g,b,[OBP_PRECISION,PRECISION_EXACT,TAG_END]) UNTIL (apens[pn]>0) ENDIF IF apens[pn]=-1 THEN apens[pn]:=pn ELSE bgpen:=ObtainBestPenA(cm,r,g,b,[OBP_PRECISION,PRECISION_GUI]) ENDIF pn:=pn+1;IF pn>255 THEN pn:=255 ENDFOR ENDIF ENDFOR FOR i:=0 TO MAXCELS cel:=cels[i] IF cel cel.recolor() ENDIF ENDFOR ready() updatelist() ELSE uf:=New(4096) FOR i:=0 TO 15 IF (palet[i].color[curpal]<>0) FOR t:=0 TO (palet[i].color_num-1) uf[pn*3]:=(Long(palet[i].color[curpal]+(t*12))) uf[pn*3+1]:=(Long(palet[i].color[curpal]+(t*12)+4)) uf[pn*3+2]:=(Long(palet[i].color[curpal]+(t*12)+8)) SetRGB32CM(cm,pn,uf[pn*3],uf[pn*3+1],uf[pn*3+2]) pn:=pn+1;IF pn>255 THEN pn:=255 ENDFOR ENDIF ENDFOR RethinkDisplay() RemakeDisplay() Dispose(uf) updatelist() ENDIF ENDPROC PROC findcolor(r1,g1,b1) DEF score,pick,news,r,g,b,i,t,pn=0 score:=1000000;pick:=0 FOR i:=0 TO 15 IF (palet[i].color[curpal]<>0) FOR t:=0 TO (palet[i].color_num-1) r:=(Long(palet[i].color[curpal]+(t*12))) g:=(Long(palet[i].color[curpal]+(t*12)+4)) b:=(Long(palet[i].color[curpal]+(t*12)+8)) r:=long2byte(r) g:=long2byte(g) b:=long2byte(b) r:=Abs(r-r1) g:=Abs(g-g1) b:=Abs(b-b1) news:=(r*r)+(g*g)+(b*b) IF (news<score) pick:=pn score:=news ENDIF ->WriteF('\nr=\d[3] g=\d[3] b=\d[3] score=\d best=\d',r1,g1,b1,news,score) pn:=pn+1;IF pn>255 THEN pn:=255 ENDFOR ENDIF ENDFOR ENDPROC pick PROC savecoords(newfh) DEF obj:PTR TO obj DEF cel:PTR TO cel DEF zz,zzz,t,tt,i,ii DEF string[500]:STRING IF newfh FOR i:=0 TO 9 StringF(string,'\n$\d[1]',pb[i]) Write(newfh,string,StrLen(string)) ii:=0 FOR t:=0 TO MAXCELS cel:=cels[t] IF cel IF (cel.sets[i]) ii:=bigger(ii,cel.obj) ENDIF ENDIF ENDFOR FOR t:=0 TO ii STEP 16 FOR tt:=t TO smaller(t+15,ii) zz:=-11 FOR zzz:=0 TO MAXCELS cel:=cels[zzz] IF cel IF cel.sets[i] IF (cel.obj=tt) obj:=objs[cel.obj] IF obj zz:=zzz ENDIF ENDIF ENDIF ENDIF ENDFOR IF zz>=0 StringF(string,' \d,\d',obj.x[i],obj.y[i]) Write(newfh,string,StrLen(string)) ELSE Write(newfh,' *',2) ENDIF ENDFOR Write(newfh,'\n',1) ENDFOR Write(newfh,'\n',1) ENDFOR Write(newfh,'\n;This .cnf file was saved by PlayFKISS for Amiga Computers.',STRLEN) ENDIF ENDPROC PROC saveall(cname) DEF dir[500]:STRING DEF file[500]:STRING DEF string[500]:STRING DEF filename[500]:STRING DEF ii=0,i DEF oldfh,newfh DEF bufptr,filebuf,filelen DEF oldout DEF obj:PTR TO obj DEF cel:PTR TO cel DEF event:PTR TO event DEF com:PTR TO command DEF next1,next2 DEF select StrCopy(filename,cname,ALL) splitname(filename,dir,file) WbenchToFront() ii:=AslRequest(filereq,[ASL_HAIL,'Save .CNF file as?', ASL_OKTEXT,'Save',ASL_FILE,file,ASL_DIR,dir, ASLFR_DOPATTERNS,TRUE,ASLFR_DOSAVEMODE,TRUE,FILF_NEWIDCMP,TRUE,NIL,NIL]) IF onwb=0 THEN WbenchToBack() IF ii StrCopy(string,filename,ALL) StrCopy(filename,filereq.drawer,ALL) eaddpart(filename,filereq.file,490) oldfh:=Open(filename,MODE_OLDFILE) newfh:=1 IF oldfh Close(oldfh) newfh:=EasyRequestArgs(win,[20,0,'Sorry:','Overwriting existing .cnf files is forbidden!', 'Understood'],0,0) newfh:=0 ENDIF IF newfh newfh:=Open(filename,MODE_NEWFILE) IF newfh busy() oldout:=SetStdOut(newfh) WriteF(';\n;This file was written by PlayFKISS for Amiga Computers\n;\n') FOR i:=0 TO 15 IF StrLen(palet[i].name) splitname(palet[i].name,dir,file) WriteF('%\s\n',file) ENDIF ENDFOR WriteF('(\d,\d) ;Environment dimensions\n',envw,envh) WriteF('[0 ;Border color\n\n') FOR i:=MAXCELS TO 0 STEP -1 cel:=cels[i] IF cel obj:=objs[cel.obj] IF obj WriteF('#\d',cel.obj) IF obj.fix WriteF('.\d ',obj.fix) ELSE WriteF(' ') ENDIF WriteF('\s *\d :',cel.realname,cel.palet_num) FOR ii:=0 TO 9 IF cel.sets[ii] WriteF('\d ',ii) ELSE WriteF(' ') ENDIF ENDFOR WriteF(' ;\s\n',cel.comment) ENDIF ENDIF ENDFOR IF (fkissfound) WriteF(';\n;\n;FKISS stuff follows:\n;\n@EventHandler()\n;\n') event:=eventlist.head REPEAT next1:=event.ln.succ IF (next1) select:=event.type SELECT select CASE EV_INIT WriteF(';@initialize()\n') CASE EV_BEGIN WriteF(';@begin()\n') CASE EV_END WriteF(';@end()\n') CASE EV_ALARM WriteF(';@alarm(\d)\n',event.obj) CASE EV_CATCH IF event.obj>-1 WriteF(';@catch(#\d)\n',event.obj) ELSE WriteF(';@catch("\s")\n',event.cel) ENDIF CASE EV_UNFIX IF event.obj>-1 WriteF(';@unfix(#\d)\n',event.obj) ELSE WriteF(';@unfix("\s")\n',event.cel) ENDIF CASE EV_FIXCATCH IF event.obj>-1 WriteF(';@fixcatch(#\d)\n',event.obj) ELSE WriteF(';@fixcatch("\s")\n',event.cel) ENDIF CASE EV_SET WriteF(';@set(\d)\n',event.obj) CASE EV_DROP IF event.obj>-1 WriteF(';@drop(#\d)\n',event.obj) ELSE WriteF(';@drop("\s")\n',event.cel) ENDIF ENDSELECT com:=event.commands.head REPEAT next2:=com.ln.succ IF (next2) select:=com.type SELECT select CASE CO_TIMER WriteF(';@ timer(\d,\d)\n',com.x,com.y) CASE CO_MAP IF com.obj>-1 WriteF(';@ map(#\d)\n',com.obj) ELSE WriteF(';@ map("\s")\n',com.cel) ENDIF CASE CO_UNMAP IF com.obj>-1 WriteF(';@ unmap(#\d)\n',com.obj) ELSE WriteF(';@ unmap("\s")\n',com.cel) ENDIF CASE CO_SOUND WriteF(';@ sound("\s")\n',com.sound) CASE CO_MOVE IF com.obj>-1 WriteF(';@ move(#\d,\d,\d)\n',com.obj,com.x,com.y) ELSE WriteF(';@ move("\s",\d,\d)\n',com.cel,com.x,com.y) ENDIF CASE CO_ALTMAP IF com.obj>-1 WriteF(';@ altmap(#\d)\n',com.obj) ELSE WriteF(';@ altmap("\s")\n',com.cel) ENDIF ENDSELECT ENDIF com:=next2 UNTIL next2=0 ENDIF event:=next1 WriteF(';\n') UNTIL next1=0 ENDIF WriteF('\n;\n;coordinates follow:\n;\n') SetStdOut(oldout) savecoords(newfh) Close(newfh) ready() ENDIF ENDIF ENDIF ENDPROC PROC appendcoords(cname) DEF dir[500]:STRING DEF file[500]:STRING DEF string[500]:STRING DEF filename[500]:STRING DEF ii=0 DEF oldfh,newfh DEF bufptr,filebuf,filelen StrCopy(filename,cname,ALL) splitname(filename,dir,file) WbenchToFront() ii:=AslRequest(filereq,[ASL_HAIL,'Append to which .CNF file?', ASL_OKTEXT,'Save',ASL_FILE,file,ASL_DIR,dir, ASLFR_DOPATTERNS,TRUE,ASLFR_DOSAVEMODE,TRUE,FILF_NEWIDCMP,TRUE,NIL,NIL]) IF onwb=0 THEN WbenchToBack() IF ii StrCopy(string,filename,ALL) StrCopy(filename,filereq.drawer,ALL) eaddpart(filename,filereq.file,490) oldfh:=Open(filename,MODE_OLDFILE) newfh:=1 IF oldfh Close(oldfh) newfh:=EasyRequestArgs(win,[20,0,'Confirm overwrite!', 'File exists.\nDo you wish to overwrite?', 'Overwrite|Cancel'],0,0) ENDIF IF newfh busy() filelen:=FileLength(string) IF (filelen>0) filebuf:=New(filelen) oldfh:=Open(string,MODE_OLDFILE) IF oldfh Read(oldfh,filebuf,filelen) Close(oldfh) bufptr:=filebuf WHILE ((((Char(bufptr)<>10) OR (Char(bufptr)<>13)) AND (Char(bufptr+1)<>"$")) AND (bufptr<=(filebuf+filelen))) bufptr:=bufptr+1 ENDWHILE newfh:=Open(filename,MODE_NEWFILE) IF newfh Write(newfh,filebuf,(bufptr-filebuf+1)) savecoords(newfh) Close(newfh) ENDIF ENDIF Dispose(filebuf) ENDIF ready() ENDIF ENDIF ENDPROC PROC savescreen(cname) DEF dir[500]:STRING DEF file[500]:STRING DEF string[500]:STRING DEF filename[500]:STRING DEF ii=0 DEF bufptr,filebuf,filelen DEF imbuf:PTR TO imbuf StrCopy(filename,cname,ALL) splitname(filename,dir,file) StrAdd(file,'.IFF') WbenchToFront() ii:=AslRequest(filereq,[ASL_HAIL,'Save Screen as', ASL_OKTEXT,'Save',ASL_FILE,file,ASL_DIR,dir, ASLFR_DOPATTERNS,TRUE,ASLFR_DOSAVEMODE,TRUE,FILF_NEWIDCMP,TRUE,NIL,NIL]) IF onwb=0 THEN WbenchToBack() IF ii busy() StrCopy(string,filename,ALL) StrCopy(filename,filereq.drawer,ALL) eaddpart(filename,filereq.file,490) NEW imbuf.new(envw,envh,depth) IF imbuf.bmap ClipBlit(rp,0,0,imbuf.rast,0,0,envw,envh,192) saveclip(filename,imbuf.bmap,vp,envw,envh,0) END imbuf ENDIF ready() ENDIF ENDPROC PROC saveclip(unitnumber,mom:PTR TO bitmap,vp:PTR TO viewport,width,height,yoffset) HANDLE DEF ierror,rlen DEF table=0 DEF bmhd=NIL:PTR TO bitmapheader DEF planedata[10]:LIST,cm DEF iff=0:PTR TO iffhandle DEF dang,dumb cm:=vp.colormap bmhd:=New(SIZEOF bitmapheader) rlen:=(((width+15)/16))*2 bmhd.width:=width bmhd.height:=height bmhd.left:=0 bmhd.top:=0 bmhd.depth:=mom.depth bmhd.masking:=0 bmhd.compression:=1 bmhd.transparent:=0 bmhd.xaspect:=1 -> change these later? bmhd.yaspect:=1 bmhd.pagewidth:=0 bmhd.pageheight:=0 iff:=AllocIFF() IF unitnumber<255 iff.stream:=OpenClipboard(unitnumber) IF (iff.stream) InitIFFasClip(iff) ELSE Raise("NOOP") ENDIF ELSE iff.stream:=Open(unitnumber,MODE_NEWFILE) IF (iff.stream) InitIFFasDOS(iff) ELSE Raise("NOOP") ENDIF ENDIF IF (ierror:=OpenIFF(iff,IFFF_WRITE)) THEN Raise("NOOP") PushChunk(iff,"ILBM","FORM",IFFSIZE_UNKNOWN) PushChunk(iff,"ILBM","ANNO",IFFSIZE_UNKNOWN) WriteChunkBytes(iff,'Written by PlayFKiss 2.04',STRLEN) PopChunk(iff) PushChunk(iff,"ILBM","BMHD",SIZEOF bitmapheader) WriteChunkBytes(iff,bmhd,SIZEOF bitmapheader) PopChunk(iff) PushChunk(iff,"ILBM","CAMG",4) WriteChunkBytes(iff,[modeid]:LONG,4) PopChunk(iff) PushChunk(iff,"ILBM","CMAP",IFFSIZE_UNKNOWN) table:=New(50) FOR dang:=0 TO (Shl(1,bmhd.depth)-1) GetRGB32(cm,dang,3,table) WriteChunkBytes(iff,(table),1) WriteChunkBytes(iff,(table+4),1) WriteChunkBytes(iff,(table+8),1) ENDFOR PopChunk(iff) IF (bmhd.depth) FOR dumb:=1 TO 8 planedata[dumb]:=Long(mom+4+(4*dumb))+(rlen*yoffset) ENDFOR PushChunk(iff,"ILBM","BODY",IFFSIZE_UNKNOWN) FOR dang:=0 TO height-1 FOR dumb:=1 TO bmhd.depth PutChar(table,rlen-1) -> Place number of bytes per row. SIMPLE COMPRESSION WriteChunkBytes(iff,table,1) WriteChunkBytes(iff,planedata[dumb]+(dang*mom.bytesperrow),rlen) ENDFOR ENDFOR PopChunk(iff) ENDIF PopChunk(iff) Raise("NONE") EXCEPT freeiff(iff,unitnumber) IF table THEN Dispose(table) IF bmhd THEN Dispose(bmhd) IF (exception<>"NONE") THEN RETURN -1 ENDPROC 0 PROC freeiff(iff:PTR TO iffhandle,unit) IF iff CloseIFF(iff) IF (iff.stream) IF unit<100;CloseClipboard(iff.stream);ELSE;Close(iff.stream);ENDIF ENDIF FreeIFF(iff) ENDIF ENDPROC PROC recalchvisible() IS win.width-win.borderleft-win.borderright PROC recalcvvisible() IS win.height-win.bordertop-win.borderbottom PROC updateprop(gadget:PTR TO object,attr,value) SetGadgetAttrsA(gadget,win,NIL,[attr,value,NIL]) ENDPROC PROC updatescroll() DEF w,h w:=recalchvisible() h:=recalcvvisible() updateprop(horizgadget,PGA_VISIBLE,w) updateprop(vertgadget,PGA_VISIBLE,h) GetAttr(PGA_TOP,horizgadget,{offx}) GetAttr(PGA_TOP,vertgadget,{offy}) updatelistbuffered(offx,offy,w,h) ENDPROC PROC openscr() DEF wbscr:PTR TO screen,addon=0 DEF pens:PTR TO INT DEF resolution,topborder,sf:PTR TO textattr,w,h,bw,bh,rw,rh,gw,gh,gap pens:=New(100) wbscr:=LockPubScreen('Workbench') IF wbscr addon:=wbscr.barheight+1 UnlockPubScreen(0,wbscr) ENDIF pens[DETAILPEN]:=findcolor(255,255,255) pens[BLOCKPEN]:=findcolor(0,0,0) pens[TEXTPEN]:=findcolor(0,0,0) IF pens[TEXTPEN]=0 THEN pens[TEXTPEN]:=findcolor(255,255,255) pens[SHINEPEN]:=findcolor(255,255,255) pens[SHADOWPEN]:=findcolor(0,0,0) pens[FILLPEN]:=findcolor(0,128,255) pens[FILLTEXTPEN]:=findcolor(255,255,255) pens[BACKGROUNDPEN]:=0 pens[HIGHLIGHTTEXTPEN]:=findcolor(196,128,32) pens[BARDETAILPEN]:=findcolor(0,0,0) pens[BARBLOCKPEN]:=findcolor(255,255,255) pens[BARTRIMPEN]:=findcolor(0,0,0) IF usewb onwb:=TRUE scr:=LockPubScreen('Workbench') depth:=scr.rastport.bitmap.depth dri:=GetScreenDrawInfo(scr) IF dri sizeimage:=newimageobject(SIZEIMAGE) leftimage:=newimageobject(LEFTIMAGE) rightimage:=newimageobject(RIGHTIMAGE) upimage:=newimageobject(UPIMAGE) downimage:=newimageobject(DOWNIMAGE) ELSE Raise("SCR") ENDIF ELSE onwb:=FALSE depth:=retdepth(mode) scr:=OpenScreenTagList(NIL,[SA_LIKEWORKBENCH,TRUE, SA_DEPTH,depth, SA_TITLE,'PlayFKiSS 2.04', SA_COLORMAPENTRIES,256, SA_FULLPALETTE,TRUE, SA_WIDTH,envw, SA_HEIGHT,envh+addon, SA_INTERLEAVED,TRUE, SA_AUTOSCROLL,screenas, SA_OVERSCAN,screenos, SA_PENS,pens, IF (modeid>0) THEN SA_DISPLAYID ELSE $80000000, modeid, NIL,NIL]) IF scr=0 THEN Raise("SCR") ENDIF IF (vis:=GetVisualInfoA(scr,NIL))=0 THEN Raise("VIS") IF (menu:=CreateMenusA([NM_TITLE,0,'Project','-',0,0,0, NM_ITEM,0,'Edit Window','W',0,0,MENU_OBJWIN, NM_ITEM,0,'Prefs...','P',0,0,MENU_PREFS, NM_ITEM,0,NM_BARLABEL,0,0,0,0, NM_ITEM,0,'Append Coordinates...','A',0,0,MENU_SAVE, NM_ITEM,0,'Save All...','S',0,0,MENU_SAVEALL, NM_ITEM,0,'Close','C',0,0,MENU_CLOSE, NM_ITEM,0,NM_BARLABEL,0,0,0,0, NM_ITEM,0,'Redraw Screen','R',0,0,MENU_REDRAW, NM_ITEM,0,'Save Screen...','E',0,0,MENU_SAVESCREEN, NM_ITEM,0,NM_BARLABEL,0,0,0,0, NM_ITEM,0,'About','?',0,0,MENU_ABOUT, NM_ITEM,0,NM_BARLABEL,0,0,0,0, NM_ITEM,0,'Quit','Q',0,0,MENU_QUIT, NM_TITLE,0,'Edit',0,0,0,0, NM_ITEM,0,'Undo','Z',0,0,MENU_UNDO, NM_ITEM,0,'Reset','T',0,0,MENU_RESETOBJ, NM_ITEM,0,NM_BARLABEL,0,0,0,0, NM_ITEM,0,'Unfix','U',0,0,MENU_UNFIXOBJ, NM_ITEM,0,'Refix','I',0,0,MENU_REFIXOBJ, NM_ITEM,0,NM_BARLABEL,0,0,0,0, NM_ITEM,0,'Move Cel Forward','+',NM_COMMANDSTRING,0,MENU_MOVEFORWARD, NM_ITEM,0,'Move Cel Back','-',NM_COMMANDSTRING,0,MENU_MOVEBACK, NM_ITEM,0,NM_BARLABEL,0,0,0,0, NM_ITEM,0,'Reveal Cel...','.',0,0,MENU_REVEAL, NM_ITEM,0,'Patrol Bounds',0,0,0,MENU_PATROL, NM_ITEM,0,NM_BARLABEL,0,0,0,0, NM_ITEM,0,'RESET',0,0,0,MENU_RESETSET, NM_TITLE,0,'Item',0,0,0,0, NM_ITEM,0,'Set',0,0 ,0,0, NM_SUB,0,'Set #0 ','F1',NM_COMMANDSTRING OR CHECKIT,%1111111110,MENU_SET0, NM_SUB,0,'Set #1','F2',NM_COMMANDSTRING OR CHECKIT,%1111111101,MENU_SET1, NM_SUB,0,'Set #2','F3',NM_COMMANDSTRING OR CHECKIT,%1111111011,MENU_SET2, NM_SUB,0,'Set #3','F4',NM_COMMANDSTRING OR CHECKIT,%1111110111,MENU_SET3, NM_SUB,0,'Set #4','F5',NM_COMMANDSTRING OR CHECKIT,%1111101111,MENU_SET4, NM_SUB,0,'Set #5','F6',NM_COMMANDSTRING OR CHECKIT,%1111011111,MENU_SET5, NM_SUB,0,'Set #6','F7',NM_COMMANDSTRING OR CHECKIT,%1110111111,MENU_SET6, NM_SUB,0,'Set #7','F8',NM_COMMANDSTRING OR CHECKIT,%1101111111,MENU_SET7, NM_SUB,0,'Set #8','F9',NM_COMMANDSTRING OR CHECKIT,%1011111111,MENU_SET8, NM_SUB,0,'Set #9','F10',NM_COMMANDSTRING OR CHECKIT,%0111111111,MENU_SET9, NM_ITEM,0,'Color',0,0 ,0,0, NM_SUB,0,'Set #0 ','1',NM_COMMANDSTRING OR CHECKIT,%1111111110,MENU_CSET0, NM_SUB,0,'Set #1','2',NM_COMMANDSTRING OR CHECKIT,%1111111101,MENU_CSET1, NM_SUB,0,'Set #2','3',NM_COMMANDSTRING OR CHECKIT,%1111111011,MENU_CSET2, NM_SUB,0,'Set #3','4',NM_COMMANDSTRING OR CHECKIT,%1111110111,MENU_CSET3, NM_SUB,0,'Set #4','5',NM_COMMANDSTRING OR CHECKIT,%1111101111,MENU_CSET4, NM_SUB,0,'Set #5','6',NM_COMMANDSTRING OR CHECKIT,%1111011111,MENU_CSET5, NM_SUB,0,'Set #6','7',NM_COMMANDSTRING OR CHECKIT,%1110111111,MENU_CSET6, NM_SUB,0,'Set #7','8',NM_COMMANDSTRING OR CHECKIT,%1101111111,MENU_CSET7, NM_SUB,0,'Set #8','9',NM_COMMANDSTRING OR CHECKIT,%1011111111,MENU_CSET8, NM_SUB,0,'Set #9','10',NM_COMMANDSTRING OR CHECKIT,%0111111111,MENU_CSET9, NM_END,0,'End','x',0,0,0]:newmenu,NIL))=NIL THEN Raise("MENU") LayoutMenusA(menu,vis,[GTMN_NEWLOOKMENUS,TRUE,NIL,NIL]) IF (onwb) IF sizeimage=0 THEN Raise("SCR") resolution:=sysisize() sf:=scr.font topborder:=scr.wbortop+sf.ysize+1 w:=sizeimage.width h:=sizeimage.height bw:=IF resolution=SYSISIZE_LOWRES THEN 1 ELSE 2 bh:=IF resolution=SYSISIZE_HIRES THEN 2 ELSE 1 rw:=IF resolution=SYSISIZE_HIRES THEN 3 ELSE 2 rh:=IF resolution=SYSISIZE_HIRES THEN 2 ELSE 1 gh:=bigger(leftimage.height,h) gh:=bigger(rightimage.height,gh) gw:=bigger(upimage.width,w) gw:=bigger(downimage.width,gw) gap:=1 horizgadget:=newpropobject(FREEHORIZ, [GA_LEFT,rw+gap, GA_RELBOTTOM,bh-gh+2, GA_RELWIDTH,(-gw)-gap-leftimage.width-rightimage.width-rw-rw, GA_HEIGHT,gh-bh-bh-2, GA_BOTTOMBORDER,TRUE, GA_ID,HORIZ_GID, PGA_TOTAL,envw, PGA_VISIBLE,envw, GA_GZZGADGET,TRUE, NIL]) vertgadget:=newpropobject(FREEVERT, [GA_RELRIGHT,bw-gw+3, GA_TOP,topborder+rh, GA_WIDTH,gw-bw-bw-4, GA_RELHEIGHT,(-topborder)-h-upimage.height-downimage.height-rh-rh, GA_RIGHTBORDER,TRUE, GA_PREVIOUS,horizgadget, GA_ID,VERT_GID, PGA_TOTAL,envh, PGA_VISIBLE,envh, GA_GZZGADGET,TRUE, NIL]) leftgadget:=newbuttonobject(leftimage, [GA_RELRIGHT,(1)-leftimage.width-rightimage.width-gw, GA_RELBOTTOM,(1)-leftimage.height, GA_BOTTOMBORDER,TRUE, GA_PREVIOUS,vertgadget, GA_ID,LEFT_GID, GA_GZZGADGET,TRUE, NIL]) rightgadget:=newbuttonobject(rightimage, [GA_RELRIGHT,(1)-rightimage.width-gw, GA_RELBOTTOM,(1)-rightimage.height, GA_BOTTOMBORDER,TRUE, GA_PREVIOUS,leftgadget, GA_ID,RIGHT_GID, GA_GZZGADGET,TRUE, NIL]) upgadget:=newbuttonobject(upimage, [GA_RELRIGHT,(1)-upimage.width, GA_RELBOTTOM,(1)-upimage.height-downimage.height-h, GA_RIGHTBORDER,TRUE, GA_PREVIOUS,rightgadget, GA_ID,UP_GID, GA_GZZGADGET,TRUE, NIL]) downgadget:=newbuttonobject(downimage, [GA_RELRIGHT,(1)-downimage.width, GA_RELBOTTOM,(1)-downimage.height-h, GA_RIGHTBORDER,TRUE, GA_PREVIOUS,upgadget, GA_ID,DOWN_GID, GA_GZZGADGET,TRUE, NIL]) IF downgadget=0 THEN Raise("WIN") win:=OpenWindowTagList(0,[WA_INNERWIDTH,envw,WA_INNERHEIGHT,envh, WA_GADGETS,horizgadget, WA_TOP,scr.barheight+1,WA_LEFT,0, WA_FLAGS,WFLG_ACTIVATE OR WFLG_SMART_REFRESH OR WFLG_GIMMEZEROZERO OR WFLG_DRAGBAR OR WFLG_DEPTHGADGET OR WFLG_SIZEGADGET OR WFLG_CLOSEGADGET, WA_SIZEBRIGHT,TRUE, WA_SIZEBBOTTOM,TRUE, WA_AUTOADJUST,TRUE, WA_BORDERLESS,FALSE, WA_BACKDROP,FALSE, WA_CUSTOMSCREEN,scr, WA_NEWLOOKMENUS,TRUE, WA_POINTER,hand1, WA_IDCMP,IDCMP_MENUPICK OR IDCMP_MOUSEBUTTONS OR IDCMP_INTUITICKS OR IDCMP_MENUVERIFY OR IDCMP_MOUSEMOVE OR IDCMP_VANILLAKEY OR IDCMP_RAWKEY OR IDCMP_NEWSIZE OR IDCMP_CLOSEWINDOW OR IDCMP_REFRESHWINDOW OR IDCMP_IDCMPUPDATE, WA_MINWIDTH,96, WA_MINHEIGHT,64, WA_TITLE,'PlayFKiss 2.04', WA_SCREENTITLE,'PlayFKiss 2.04', NIL,NIL]) ELSE win:=OpenWindowTagList(0,[WA_WIDTH,scr.width,WA_HEIGHT,scr.height-scr.barheight-1, WA_TOP,scr.barheight+1,WA_LEFT,0, WA_FLAGS,WFLG_ACTIVATE OR WFLG_SMART_REFRESH, WA_BORDERLESS,TRUE, WA_BACKDROP,TRUE, WA_CUSTOMSCREEN,scr, WA_NEWLOOKMENUS,TRUE, WA_POINTER,hand1, WA_IDCMP,IDCMP_MENUPICK OR IDCMP_MOUSEBUTTONS OR IDCMP_INTUITICKS OR IDCMP_MENUVERIFY OR IDCMP_MOUSEMOVE OR IDCMP_VANILLAKEY OR IDCMP_RAWKEY, NIL,NIL]) ENDIF IF win=0 THEN Raise("WIN") w:=recalchvisible() h:=recalcvvisible() updateprop(horizgadget,PGA_VISIBLE,w) updateprop(vertgadget,PGA_VISIBLE,h) GetAttr(PGA_TOP,horizgadget,{offx}) GetAttr(PGA_TOP,vertgadget,{offy}) SetMouseQueue(win,1) SetMenuStrip(win,menu) vp:=scr.viewport cm:=vp.colormap rp:=win.rport IF onwb=FALSE IF (retdepth(mode)<5) SetRGB32(vp,17,byte2long(160),byte2long(160),byte2long(160)) SetRGB32(vp,18,0,0,0) SetRGB32(vp,19,$FFFFFFFF,$FFFFFFFF,$FFFFFFFF) ENDIF ENDIF usecgfx:=FALSE IF (cybergfxbase<>0) IF (IsCyberModeID(modeid)<>0) THEN usecgfx:=TRUE ENDIF gbuf:=New((envw*envh)+(envw*10)) Dispose(pens) ENDPROC PROC closescr() DEF i IF win CloseWindow(win) IF (horizgadget) THEN DisposeObject(horizgadget);horizgadget:=0 IF (vertgadget) THEN DisposeObject(vertgadget);vertgadget:=0 IF (leftgadget) THEN DisposeObject(leftgadget);leftgadget:=0 IF (rightgadget) THEN DisposeObject(rightgadget);rightgadget:=0 IF (upgadget) THEN DisposeObject(upgadget);upgadget:=0 IF (downgadget) THEN DisposeObject(downgadget);downgadget:=0 win:=0 ENDIF IF vis FreeVisualInfo(vis) vis:=0 ENDIF FOR i:=1 TO 255 IF apens[i]>=0 THEN ReleasePen(cm,apens[i]) apens[i]:=-1 ENDFOR IF (bgpen>=0) THEN ReleasePen(cm,bgpen);bgpen:=-1 IF scr IF dri THEN FreeScreenDrawInfo(scr,dri);dri:=0 IF onwb IF sizeimage THEN DisposeObject(sizeimage);sizeimage:=0 IF leftimage THEN DisposeObject(leftimage);leftimage:=0 IF rightimage THEN DisposeObject(rightimage);rightimage:=0 IF upimage THEN DisposeObject(upimage);upimage:=0 IF downimage THEN DisposeObject(downimage);downimage:=0 UnlockPubScreen(0,scr) ELSE CloseScreen(scr) ENDIF scr:=0 cm:=0 ENDIF IF gbuf THEN Dispose(gbuf);gbuf:=0 WbenchToFront() ENDPROC PROC freeevents() DEF event:PTR TO event DEF com:PTR TO command DEF next1,next2 event:=eventlist.head REPEAT next1:=event.ln.succ IF (next1) com:=event.commands.head REPEAT next2:=com.ln.succ IF (next2) Remove(com) IF com.cel THEN DisposeLink(com.cel) IF com.sound THEN DisposeDTObject(com.sound) END com ENDIF com:=next2 UNTIL next2=0 Remove(event) IF event.cel THEN DisposeLink(event.cel) END event ENDIF event:=next1 UNTIL next1=0 ENDPROC PROC freepals() DEF i FOR i:=0 TO 15 StrCopy(palet[i].name,'') ENDFOR ENDPROC ver: CHAR 0,0,0,'$VER: playfkiss 2.04 (10.2.96)',10,0,0 PROC loadcnf() HANDLE DEF fh=0 DEF fib=0:PTR TO fileinfoblock DEF lock=0 DEF buf=0:PTR TO CHAR DEF dir[500]:STRING,fi[500]:STRING DEF lha[50]:STRING DEF rr=0,res=0 DEF wscr=0:PTR TO screen DEF fileloaded=0 DEF isarc=FALSE wscr:=LockPubScreen('Workbench') IF wscr NEW ezclist.new() NEW errlist.new() errlist.add(' Errors:') IF StrLen(ofilename) THEN StrCopy(afname,ofilename) NEW pppp.new('PlayFKiss') gh:=guiinit('PlayFKiss 2.04', [ROWS, [PLUGIN,0,pppp], [COLS, [ROWS, [COLS, ghafnamegad:=[STR,{loadstr},'Kiss Set',afname,50,1], ghgetgad:=[BUTTON,{getfile},'Choose...'] ], cellistv:=[LISTV,0,0,32,6,ezclist.head(),TRUE,0,0] ] ], [BEVELR, [COLS, [EQROWS, nobjgad:=[NUM,MAXOBJS,'Objs:',0,0], ncelgad:=[NUM,MAXCELS,'Cels:',0,0] ], [EQROWS, evgad:=[NUM,64738,'Events:',0,0], cogad:=[NUM,64738,'Actions:',0,0] ], [EQROWS, colgad:=[NUM,256,'Colors:',0,0], memgad:=[NUM,20000000,'Memory:',0,0] ] ] ], [COLS, errlistv:=[LISTV,0,0,8,2,errlist.head(),TRUE,0,0] ], [BAR], [EQCOLS, ppgad:=[SBUTTON,1,'Play'], [SBUTTON,{prefs},'Prefs'], [SBUTTON,{aboutme},'About'], qqgad:=[SBUTTON,2,'Quit'] ] ] ,0,wscr) sizewin(gh.wnd,GH_MAIN) pppp.setlevel(0,10) pppp.text('Select .cnf file...') cellistgad:=findgadget(gh,cellistv) errlistgad:=findgadget(gh,errlistv) playgad:=findgadget(gh,ppgad) quitgad:=findgadget(gh,qqgad) getgad:=findgadget(gh,ghgetgad) afnamegad:=findgadget(gh,ghafnamegad) IF (fib:=AllocDosObject(DOS_FIB,0))=0 THEN Raise("err") continue:=0 rr:=0 res:=0 fileloaded:=0 REPEAT IF StrLen(afname) splitname(afname,dir,fi) RightStr(lha,fi,4) IF stricmp('.lha',lha,4) dearc(afname,0) isarc:=TRUE ELSE IF stricmp('.lzh',lha,4) dearc(afname,0) isarc:=TRUE ELSE IF stricmp('.lzx',lha,4) dearc(afname,1) isarc:=TRUE ELSE isarc:=0 ENDIF ENDIF ENDIF rr:=0 IF (lock:=Lock(afname,SHARED_LOCK)) Examine(lock,fib) IF (fh:=Open(afname,MODE_OLDFILE)) IF (buf:=New(fib.size+32)) playgad:=findgadget(gh,ppgad) Gt_SetGadgetAttrsA(playgad,gh.wnd,0,[GA_DISABLED,TRUE,TAG_END]) quitgad:=findgadget(gh,qqgad) Gt_SetGadgetAttrsA(quitgad,gh.wnd,0,[GA_DISABLED,TRUE,TAG_END]) getgad:=findgadget(gh,ghgetgad) Gt_SetGadgetAttrsA(getgad,gh.wnd,0,[GA_DISABLED,TRUE,TAG_END]) afnamegad:=findgadget(gh,ghafnamegad) Gt_SetGadgetAttrsA(afnamegad,gh.wnd,0,[GA_DISABLED,TRUE,TAG_END]) Read(fh,buf,fib.size) setlistvlabels(gh,cellistv,-1) END ezclist NEW ezclist.new() ezclist.add(' Cel List:') setlistvlabels(gh,cellistv,ezclist.head()) splitname(afname,dir,fi) rr:=parsecnf(buf,fib.size,dir) Close(fh);fh:=0 fileloaded:=TRUE playgad:=findgadget(gh,ppgad) Gt_SetGadgetAttrsA(playgad,gh.wnd,0,[GA_DISABLED,FALSE,TAG_END]) quitgad:=findgadget(gh,qqgad) Gt_SetGadgetAttrsA(quitgad,gh.wnd,0,[GA_DISABLED,FALSE,TAG_END]) getgad:=findgadget(gh,ghgetgad) Gt_SetGadgetAttrsA(getgad,gh.wnd,0,[GA_DISABLED,FALSE,TAG_END]) afnamegad:=findgadget(gh,ghafnamegad) Gt_SetGadgetAttrsA(afnamegad,gh.wnd,0,[GA_DISABLED,FALSE,TAG_END]) Dispose(buf);buf:=0 ENDIF ENDIF UnLock(lock);lock:=0 ENDIF ENDIF WHILE res<=0 afnamegad:=findgadget(gh,ghafnamegad) RefreshGList(afnamegad,gh.wnd,0,1) Wait(gh.sig) stepon:=0 res:=guimessage(gh) IF res>0 continue:=res IF (res=1) THEN rr:=1 ENDIF IF stepon THEN res:=5 ENDWHILE IF res=5 THEN res:=0 UNTIL continue ENDIF EXCEPT DO IF isarc THEN cleanuparc() IF gh rememberwin(gh.wnd,GH_MAIN) cleangui(gh) gh:=0 ENDIF IF pppp THEN END pppp;pppp:=0 IF wscr THEN UnlockPubScreen(0,wscr) IF fib THEN FreeDosObject(DOS_FIB,fib) IF lock THEN UnLock(lock) IF buf THEN Dispose(buf) END ezclist;ezclist:=0 END errlist;errlist:=0 IF fh THEN Close(fh) IF exception="Egui" THEN ReThrow() IF exception="bigg" THEN ReThrow() IF exception="file" THEN RETURN "file" ENDPROC rr PROC getscreenname(str) DEF res DEF buf:PTR TO nameinfo IF (buf:=New(1000)) res:=GetDisplayInfoData(0,buf,1000,DTAG_NAME,tmodeid) IF res StrCopy(str,buf.name) IF (prefhand) THEN settext(prefhand,modename,str) ENDIF Dispose(buf) ENDIF ENDPROC PROC loadprefs(name) DEF buffy:PTR TO LONG,fh,i buffy:=New(800) fh:=Open(name,MODE_OLDFILE) IF fh Read(fh,buffy,100) Close(fh) modeid:=buffy[0] screenos:=buffy[1] screenas:=buffy[2] animspeed:=buffy[3] usebounds:=buffy[4] usehand:=buffy[5] usefollow:=buffy[7] usesnap:=buffy[8] usenasty:=buffy[9] useregions:=buffy[10] usewb:=buffy[11] usewin:=buffy[12] ENDIF fh:=Open('ENV:PlayFKiss.windows',MODE_OLDFILE) IF fh Read(fh,buffy,48) Close(fh) FOR i:=0 TO 2 wx[i]:=buffy[(i*4)] wy[i]:=buffy[(i*4)+1] ww[i]:=buffy[(i*4)+2] wh[i]:=buffy[(i*4)+3] ENDFOR ENDIF Dispose(buffy) ENDPROC PROC saveprefs(name) DEF buffy:PTR TO LONG,fh buffy:=New(100) buffy[0]:=modeid buffy[1]:=screenos buffy[2]:=screenas buffy[3]:=animspeed buffy[4]:=usebounds buffy[5]:=usehand buffy[7]:=usefollow buffy[8]:=usesnap buffy[9]:=usenasty buffy[10]:=useregions buffy[11]:=usewb buffy[12]:=usewin fh:=Open(name,MODE_NEWFILE) IF fh Write(fh,buffy,100) Close(fh) ENDIF ENDPROC PROC savewinpos() savewp('ENV:PlayFKiss.windows') savewp('ENVARC:PlayFKiss.windows') ENDPROC PROC savewp(name) DEF buffy:PTR TO LONG,fh,i buffy:=New(800) FOR i:=0 TO 2 buffy[(i*4)]:=wx[i] buffy[(i*4)+1]:=wy[i] buffy[(i*4)+2]:=ww[i] buffy[(i*4)+3]:=wh[i] ENDFOR fh:=Open(name,MODE_NEWFILE) IF fh Write(fh,buffy,48) Close(fh) ENDIF ENDPROC PROC setspeed(dum,val) tanimspeed:=val*10 ENDPROC PROC prefs() DEF res=0 prefhand:=0 tmodeid:=modeid tscreenos:=screenos tscreenas:=screenas tanimspeed:=animspeed tusebounds:=usebounds tusehand:=usehand tuseregions:=useregions tusefollow:=usefollow tusesnap:=usesnap tusenasty:=usenasty tusewb:=usewb tusewin:=usewin getscreenname(sname) prefhand:=guiinit('PlayFKiss Prefs', [ROWS, [COLS, [TEXT,0,'Display:',0,1], [BEVELR, modename:=[TEXT,sname,0,0,1] ], [BUTTON,{getsmr},'Choose...'] ], [COLS, [TEXT,' ','Anim Speed',0,1], [SLIDE,{setspeed},0,FALSE,0,20,animspeed/10,20,'\d[2]'] ], [EQCOLS, [EQROWS, [CHECK,{bound},'Enforce Bounds:',tusebounds,TRUE], [CHECK,{optfollow},'Follow Mouse:',tusefollow,TRUE], -> [CHECK,{hand},'Hand Pointer:',tusehand,TRUE], [CHECK,{snap},'Elastic Fix:',tusesnap,TRUE] ], [EQROWS, [CHECK,{uwb},'Window on Workbench:',tusewb,TRUE], [CHECK,{uwin},'Remember Windows:',tusewin,TRUE], [CHECK,{nasty},'Use CyberGFX:',tusenasty,TRUE] ] ], [COLS, [CYCLE,{optreg},'Update:',['Object Regions','Cel Regions','Simple Square',0],tuseregions], [CYCLE,{hand},'Pointer:',['System','Hand','Blank',0],tusehand] ], [BAR], [COLS, [BUTTON,4,'Save'], [SPACEH], [BUTTON,2,'Use'], [SPACEH], [BUTTON,3,'Cancel'] ] ] ,0,IF scr THEN scr ELSE 0) sizewin(prefhand.wnd,GH_PREFS) res:=-1 IF prefhand WHILE res<0 Wait(prefhand.sig) res:=guimessage(prefhand) ENDWHILE rememberwin(prefhand.wnd,GH_PREFS) cleangui(prefhand) ENDIF IF (res=2) OR (res=4) modeid:=tmodeid screenos:=tscreenos screenas:=tscreenas animspeed:=tanimspeed usebounds:=tusebounds usehand:=tusehand useregions:=tuseregions usefollow:=tusefollow usesnap:=tusesnap usenasty:=tusenasty usewb:=tusewb usewin:=tusewin ENDIF IF res=4 saveprefs('ENVARC:PlayFKISS.prefs') res:=2 ENDIF IF res=2 saveprefs('ENV:PlayFKISS.prefs') ENDIF ENDPROC PROC bound(ac,val) tusebounds:=val ENDPROC PROC hand(ac,val) tusehand:=val ENDPROC PROC uwin(ac,val) tusewin:=val ENDPROC PROC optreg(ac,val) tuseregions:=val ENDPROC PROC optfollow(ac,val) tusefollow:=val ENDPROC PROC snap(ac,val) tusesnap:=val ENDPROC PROC nasty(ac,val) tusenasty:=val ENDPROC PROC uwb(ac,val) tusewb:=val ENDPROC PROC getsmr() DEF ret ret:=AslRequest(smr, [IF scr THEN ASLSM_SCREEN ELSE ASLSM_PUBSCREENNAME,IF scr THEN scr ELSE 'Workbench', ASLSM_DOOVERSCANTYPE,TRUE, ASLSM_DOAUTOSCROLL,TRUE, ASLSM_INITIALDISPLAYID,tmodeid, ASLSM_INITIALOVERSCANTYPE,tscreenos, ASLSM_INITIALAUTOSCROLL,tscreenas, NIL]) IF ret tmodeid:=smr.displayid tscreenas:=smr.autoscroll tscreenos:=smr.overscantype getscreenname(sname) ENDIF ENDPROC PROC getfile() DEF ii DEF file[500]:STRING,dir[500]:STRING splitname(afname,dir,file) ii:=AslRequest(filereq,[ASL_HAIL,'Select .CNF file', ASL_OKTEXT,'Open',ASL_FILE,file,ASL_DIR,dir, ASLFR_DOPATTERNS,TRUE,ASLFR_DOSAVEMODE,FALSE,FILF_NEWIDCMP,TRUE,NIL,NIL]) IF ii StrCopy(afname,filereq.drawer,ALL) eaddpart(afname,filereq.file,490) setstr(gh,ghafnamegad,afname) stepon:=1 ENDIF ENDPROC PROC loadstr() stepon:=1 ENDPROC PROC parsecnf(buf:PTR TO CHAR,lof,dirname) HANDLE DEF mark=0,smark,omark,result DEF objn,celn,fixval DEF lc DEF res=0,nres=0 DEF str[12]:STRING DEF numstr[12]:STRING DEF alstr[100]:STRING DEF celname[100]:STRING,cel:PTR TO cel DEF obj:PTR TO obj DEF i DEF tmpstr[500]:STRING DEF cset=-1,ccel=-1 DEF celsetfound,celpalfound DEF w,h DEF aa DEF acurobj=0:PTR TO event DEF curc,tcels linenum:=1 events:=0;setnum(gh,evgad,events) commands:=0;setnum(gh,cogad,commands) palset:=0 totmem:=0 mode:=0 fkissfound:=0 freecels() freeobjs() freepals() freeevents() FOR i:=0 TO 9 pb[i]:=0 ENDFOR pppp.setlevel(0,10) pppp.text('Parsing .cnf file...') envw:=448 envh:=320 REPEAT lc:=buf[mark] SELECT lc CASE "$" smark:=mark+1 cset:=cset+1 ccel:=-1 smark,result:=scan_value(buf,smark,numstr,lof) IF result=0 StrToLong(numstr,{i}) pb[cset]:=i ccel:=parsesetline(buf,smark+1,lof,cset,ccel,gh) ELSE egerr() ENDIF CASE " " IF cset>=0 ccel:=parsesetline(buf,mark+1,lof,cset,ccel,gh) ENDIF CASE ";" IF buf[mark+1]="@" IF stricmp('EventHandler',buf+mark+2,12) fkissfound:=TRUE ENDIF IF fkissfound mark,acurobj:=parsefkiss(buf,mark+2,lof,acurobj,dirname) ENDIF ENDIF CASE "%" StrCopy(celname,'') scan_string(buf,mark+1,celname,lof) IF celname load_palet(dirname,celname,gh) palset:=palset+1 setnum(gh,colgad,palset*16) ENDIF CASE "[" smark:=mark+1 smark,result:=scan_value(buf,smark,numstr,lof) IF result=0 StrToLong(numstr,{backcolor}) ELSE backcolor:=0 ENDIF CASE "(" smark:=mark+1 smark,result:=scan_value(buf,smark,numstr,lof) IF result=0 StrToLong(numstr,{envw}) envw:=((envw+31)/32)*32 smark,result:=scan_value(buf,smark+1,numstr,lof) IF result=0 StrToLong(numstr,{envh}) ELSE egerr() ENDIF ELSE egerr() ENDIF CASE "#" cel:=0 fixval:=0 StrCopy(celname,'') smark:=mark+1 StrCopy(numstr,'') smark,result:=scan_value(buf,smark,numstr,lof) IF result=0 StrToLong(numstr,{objn}) IF buf[smark]="." smark:=smark+1 StrCopy(numstr,'') smark,result:=scan_value(buf,smark,numstr,lof) IF result=0 StrToLong(numstr,{fixval}) ELSE egerr() ENDIF ENDIF smark:=scan_nonspace(buf,smark,lof) smark:=scan_string(buf,smark,celname,lof) IF (StrLen(celname)) -> setlistvlabels(gh,cellistv,-1) cel:=alloccel() IF (cel) cel.realname(celname) cel.setobj(objn) cel.fix:=fixval obj:=allocobj(objn) obj.fix:=bigger(fixval,obj.fix) obj.oldfix:=obj.fix /* StringF(tmpstr,'\s #\d',celname,cel.obj) ezclist.add(tmpstr) setlistvlabels(gh,cellistv,ezclist.head()) */ setnum(gh,ncelgad,countcels()) setnum(gh,nobjgad,countobjs()) FOR i:=0 TO 9 cel.setset(i,1) ENDFOR celsetfound:=FALSE;celpalfound:=FALSE omark:=smark WHILE ((buf[smark]<>10) AND (buf[smark]<>13) AND (smark<lof) AND (buf[smark]<>";")) IF ((buf[smark]="*") AND (celpalfound=FALSE)) celpalfound:=TRUE smark:=smark+1 smark,result:=scan_value(buf,smark,numstr,lof) IF result=0 StrToLong(numstr,{i}) cel.setpalette(i) ELSE egerr() ENDIF ENDIF IF ((buf[smark]=":") AND (celsetfound=FALSE)) celsetfound:=TRUE FOR i:=0 TO 9 cel.setset(i,0) ENDFOR smark:=smark+1 WHILE ((buf[smark]<>10) AND (buf[smark]<>13) AND (smark<lof) AND (buf[smark]<>";")) StrCopy(numstr,buf+smark,1) IF ((buf[smark]>="0") AND (buf[smark]<="9")) StrToLong(numstr,{i}) cel.setset(i,1) ENDIF smark:=smark+1 ENDWHILE smark:=smark-1 ENDIF smark:=smark+1 ENDWHILE i:=omark smark:=i WHILE ((buf[i]<>10) AND (buf[i]<>13)) IF buf[i]=";" smark:=i ENDIF i:=i+1 ENDWHILE IF (smark<(i-1)) StrCopy(tmpstr,buf+smark+1,i-smark-1) cel.comment(tmpstr) ELSE cel.comment('-') ENDIF ENDIF ELSE egerr() ENDIF ELSE egerr() ENDIF ENDSELECT mark:=seekcrlf(buf,mark,lof);linenum:=linenum+1 nres:=guimessage(gh) IF nres>0 THEN res:=nres UNTIL (mark>=lof) pppp.text('Loading cel files...') tcels:=countcels() curc:=0 FOR i:=MAXCELS TO 0 STEP -1 cel:=cels[i] IF cel setloaded:=TRUE IF ((i/3)=((i+2)/3)) pppp.setlevel(smaller(curc,tcels),bigger(tcels,1)) ENDIF curc:=curc+1 w,h:=cel.load(dirname) setlistvlabels(gh,cellistv,-1) IF w>0 AND h>0 StringF(tmpstr,'\s #\d (\dx\d) *\d [\d\d\d\d\d\d\d\d\d\d] ;\s',cel.realname,cel.obj,w,h,cel.palet_num,cel.sets[0],cel.sets[1],cel.sets[2],cel.sets[3],cel.sets[4],cel.sets[5],cel.sets[6],cel.sets[7],cel.sets[8],cel.sets[9],cel.comment) totmem:=totmem+(w*h) IF usewb THEN totmem:=totmem+(w*h) setnum(gh,memgad,totmem) ELSE StringF(tmpstr,'*\s -BAD FILE/NOT FOUND',celname) ENDIF ezclist.add(tmpstr) setlistvlabels(gh,cellistv,ezclist.head()) nres:=guimessage(gh) IF nres>0 THEN res:=nres ENDIF ENDFOR pppp.setlevel(0,10) pppp.text('Ready!') EXCEPT DO NOP ENDPROC res PROC parsefkiss(buf:PTR TO CHAR,mark,lof,bcurobj,dirname) DEF m,x,y DEF com:PTR TO command DEF eol=0 DEF lol=0 DEF cb,ce DEF cmpstr[100]:STRING DEF numb,num[100]:STRING DEF soundstr[1000]:STRING DEF foundcel[100]:STRING,foundobj lol:=findlol(buf,mark) m:=mark ce:=bcurobj IF lol>mark REPEAT StrCopy(cmpstr,buf+m,80) StrCopy(foundcel,'') IF stricmp(cmpstr,'initialize',10) -> >> INITIALIZE event ce:=makeevent(EV_INIT,-1,0) m:=findchar(buf,m,")") ENDIF IF stricmp(cmpstr,'begin',5) -> >> BEGIN event ce:=makeevent(EV_BEGIN,-1,0) m:=findchar(buf,m,")") ENDIF IF stricmp(cmpstr,'end',3) -> >> END event ce:=makeevent(EV_END,-1,0) m:=findchar(buf,m,")") ENDIF IF stricmp(cmpstr,'alarm(',6) -> >> ALARM event MidStr(num,cmpstr,6,20) StrToLong(num,{numb}) ce:=makeevent(EV_ALARM,numb,0) m:=findchar(buf,m,")") ENDIF IF stricmp(cmpstr,'set(',4) -> >> SET event MidStr(num,cmpstr,4,20) StrToLong(num,{numb}) ce:=makeevent(EV_SET,numb,0) m:=findchar(buf,m,")") ENDIF IF stricmp(cmpstr,'catch(',6) -> >> CATCH event foundobj:=parseparas(buf,m+6,foundcel) IF foundobj<>-1 ce:=makeevent(EV_CATCH,foundobj,0) ELSE ce:=makeevent(EV_CATCH,-1,foundcel) ENDIF m:=findchar(buf,m,")") ENDIF IF stricmp(cmpstr,'fixcatch(',9) -> >> FIXCATCH event foundobj:=parseparas(buf,m+9,foundcel) IF foundobj<>-1 ce:=makeevent(EV_FIXCATCH,foundobj,0) ELSE ce:=makeevent(EV_FIXCATCH,-1,foundcel) ENDIF m:=findchar(buf,m,")") ENDIF IF stricmp(cmpstr,'press(',6) -> >> PRESS event foundobj:=parseparas(buf,m+6,foundcel) IF foundobj<>-1 ce:=makeevent(EV_PRESS,foundobj,0) ELSE ce:=makeevent(EV_PRESS,-1,foundcel) ENDIF m:=findchar(buf,m,")") ENDIF IF stricmp(cmpstr,'drop(',5) -> >> DROP event foundobj:=parseparas(buf,m+5,foundcel) IF foundobj<>-1 ce:=makeevent(EV_DROP,foundobj,0) ELSE ce:=makeevent(EV_DROP,-1,foundcel) ENDIF m:=findchar(buf,m,")") ENDIF IF stricmp(cmpstr,'fixdrop(',5) -> >> FIXDROP event foundobj:=parseparas(buf,m+5,foundcel) IF foundobj<>-1 ce:=makeevent(EV_FIXDROP,foundobj,0) ELSE ce:=makeevent(EV_FIXDROP,-1,foundcel) ENDIF m:=findchar(buf,m,")") ENDIF IF stricmp(cmpstr,'release(',8) -> >> RELEASE event foundobj:=parseparas(buf,m+8,foundcel) IF foundobj<>-1 ce:=makeevent(EV_RELEASE,foundobj,0) ELSE ce:=makeevent(EV_RELEASE,-1,foundcel) ENDIF m:=findchar(buf,m,")") ENDIF IF stricmp(cmpstr,'unfix(',6) -> >> UNFIX event foundobj:=parseparas(buf,m+6,foundcel) IF foundobj<>-1 ce:=makeevent(EV_UNFIX,foundobj,0) ELSE ce:=makeevent(EV_UNFIX,-1,foundcel) ENDIF m:=findchar(buf,m,")") ENDIF IF stricmp(cmpstr,'timer(',6) -> >> TIMER command x,y:=parsecoords(buf,m+6) addcommand(ce,CO_TIMER,0,0,x,y) m:=findchar(buf,m,")") ENDIF IF stricmp(cmpstr,'move(',5) -> >> TIMER command foundobj:=parseparas(buf,m+5,foundcel) m:=findchar(buf,m,",") x,y:=parsecoords(buf,m+1) IF foundobj<>-1 addcommand(ce,CO_MOVE,foundobj,0,x,y) ELSE addcommand(ce,CO_MOVE,-1,foundcel,x,y) ENDIF m:=findchar(buf,m,")") ENDIF IF stricmp(cmpstr,'altmap(',7) -> >> ALTMAP command foundobj:=parseparas(buf,m+7,foundcel) IF foundobj<>-1 addcommand(ce,CO_ALTMAP,foundobj,0) ELSE addcommand(ce,CO_ALTMAP,-1,foundcel) ENDIF m:=findchar(buf,m,")") ENDIF IF stricmp(cmpstr,'unmap(',6) -> >> UNMAP command foundobj:=parseparas(buf,m+6,foundcel) IF foundobj<>-1 addcommand(ce,CO_UNMAP,foundobj,0) ELSE addcommand(ce,CO_UNMAP,-1,foundcel) ENDIF m:=findchar(buf,m,")") ENDIF IF stricmp(cmpstr,'map(',4) -> >> MAP command foundobj:=parseparas(buf,m+4,foundcel) IF foundobj<>-1 addcommand(ce,CO_MAP,foundobj,0) ELSE addcommand(ce,CO_MAP,-1,foundcel) ENDIF m:=findchar(buf,m,")") ENDIF IF stricmp(cmpstr,'sound(',6) -> >> SOUND command foundobj:=parseparas(buf,m+6,foundcel) IF foundcel<>-1 com:=addcommand(ce,CO_SOUND,-1,foundcel) IF com StrCopy(soundstr,dirname) eaddpart(soundstr,com.cel,990) com.sound:=NewDTObjectA(soundstr,[DTA_GROUPID,GID_SOUND,DTA_SOURCETYPE,DTST_FILE,NIL]) ENDIF ENDIF m:=findchar(buf,m,")") ENDIF m:=m+1 UNTIL ((eol<>0) OR (m>=lof) OR (m>=lol)) ENDIF ENDPROC m,ce PROC parseparas(buf:PTR TO CHAR,mark,str) DEF m DEF lc DEF hey[100]:STRING,hv m:=mark IF buf[m]=34 lc:=findchar(buf,m+1,34) MidStr(str,buf,m+1,lc-m-1) ->WriteF('"\s"\n',str) RETURN -1 ELSE IF buf[m]="#" lc:=findchar(buf,m+1,"#") MidStr(hey,buf,m+1,lc-m-1) StrToLong(hey,{hv}) ->WriteF('#\d\n',hv) RETURN hv ELSE egerr() ENDIF ENDIF ENDPROC PROC parsecoords(buf:PTR TO CHAR,mark) DEF x=0,y=0,m,s=0 DEF st[100]:STRING m:=mark s:=InStr(buf,',',mark) IF s>mark MidStr(st,buf,mark,s-mark) StrToLong(st,{x}) MidStr(st,buf,s+1) StrToLong(st,{y}) ENDIF ENDPROC x,y PROC findchar(buf:PTR TO CHAR,mark,char) WHILE (buf[mark]<>char) mark:=mark+1 ENDWHILE ENDPROC mark PROC makeevent(type,obj,cel) DEF ev=0:PTR TO event NEW ev ev.obj:=obj ev.type:=type ev.counter:=0 IF cel ev.cel:=String(StrLen(cel)) StrCopy(ev.cel,cel) ENDIF newList(ev.commands) AddTail(eventlist,ev) events:=events+1 setnum(gh,evgad,events) ENDPROC ev PROC addcommand(ev:PTR TO event,type,obj,cel,x=0,y=0) DEF co:PTR TO command IF ev NEW co co.obj:=obj co.type:=type co.x:=x co.y:=y IF cel co.cel:=String(StrLen(cel)) StrCopy(co.cel,cel) ENDIF AddTail(ev.commands,co) commands:=commands+1 setnum(gh,cogad,commands) ENDIF ENDPROC co PROC findeventtype(type,obj=-1,cel=-1) DEF ev:PTR TO event,next DEF str1[500]:STRING DEF str2[500]:STRING ev:=eventlist.head REPEAT next:=ev.ln.succ IF (next) IF ev.type=type IF obj=-1 IF ((ev.cel>0) AND (cel>0)) StrCopy(str1,ev.cel) StrCopy(str2,cel) UpperStr(str1) UpperStr(str2) IF StrCmp(str1,str2) RETURN ev ENDIF ELSE IF cel=-1 THEN RETURN ev ENDIF ELSE IF obj=ev.obj THEN RETURN ev ENDIF ENDIF ENDIF ev:=next UNTIL (next=0) ENDPROC 0 PROC findnamedcel(name) DEF i,cel:PTR TO cel DEF str1[200]:STRING,str2[200]:STRING StrCopy(str1,name,ALL) UpperStr(str1) FOR i:=MAXCELS TO 0 STEP -1 cel:=cels[i] IF cel StrCopy(str2,cel.realname,ALL) UpperStr(str2) IF StrCmp(str1,str2) RETURN i ENDIF ENDIF ENDFOR ENDPROC 0 PROC findlol(buf:PTR TO CHAR,mark) DEF m m:=mark WHILE ((buf[m]<>10) AND (buf[m]<>13) AND (buf[m]<>";")) m:=m+1 ENDWHILE ENDPROC m PROC load_palet(dir,fn,gh) DEF fh DEF buf:PTR TO CHAR DEF p,c,r,g,b,len,loop DEF name[500]:STRING DEF byte_l,byte_h DEF buffer:PTR TO CHAR,lof StrCopy(name,dir) AddPart(name,fn,490) fh:=Open(name,MODE_OLDFILE) IF fh StrCopy(palet[palset].name,name) lof:=FileLength(name) IF lof>0 IF (buffer:=New(lof)) Read(fh,buffer,lof) buf:=buffer IF Long(buffer)="KiSS" IF buf[4]=FILE_MARK_PALET palet[palset].color_num:=buf[9]*256+buf[8] IF (palet[palset].color_num>16) mode:=16 ELSE mode:=limit(mode+1,1,16) ENDIF palet[palset].palet_num:=buf[11]*256+buf[10] palet[palset].bit_per_pixel:=buf[5] ENDIF buf:=buf+32 ELSE palet[palset].color_num:=GS1_MAX_COLOR palet[palset].palet_num:=10 palet[palset].bit_per_pixel:=12 mode:=limit(mode+1,1,16) ENDIF p:=0 WHILE (p<palet[palset].palet_num) palet[palset].color[p]:=New(12*palet[palset].color_num+50) c:=0 WHILE (c<palet[palset].color_num) IF palet[palset].bit_per_pixel=12 byte_l:=buf[0] byte_h:=buf[1] buf:=buf+2 r:=((byte_l/$10) AND $F)*$1111 g:=(byte_h AND $F)*$1111 b:=(byte_l AND $F)*$1111 r:=(Shl(Shl(r,8),8) OR r) g:=(Shl(Shl(g,8),8) OR g) b:=(Shl(Shl(b,8),8) OR b) ENDIF IF palet[palset].bit_per_pixel=24 r:=buf[0] g:=buf[1] b:=buf[2] buf:=buf+3 FOR loop:=0 TO 2 r:=Shl(r,8) OR r g:=Shl(g,8) OR g b:=Shl(b,8) OR b ENDFOR ENDIF PutLong(palet[palset].color[p]+(12*c),r) PutLong(palet[palset].color[p]+(12*c)+4,g) PutLong(palet[palset].color[p]+(12*c)+8,b) c:=c+1 ENDWHILE p:=p+1 ENDWHILE ENDIF ENDIF Close(fh) ELSE pppp.setlevel(0,10) pppp.text('Missing a .kcf file!') DisplayBeep(0) Delay(120) ENDIF ENDPROC PROC parsesetline(buf:PTR TO CHAR,m,lof,cs,co,gh) HANDLE DEF xxx,yyy DEF oldco DEF mm,mmm DEF res DEF nstr[10]:STRING DEF obj:PTR TO obj oldco:=co WHILE ((buf[m]<>13) AND (buf[m]<>10) AND (buf[m+1]<>13) AND (buf[m+1]<>10) AND (buf[m-1]<>13) AND (buf[m-1]<>10) AND (m<lof)) m:=scan_nonspace(buf,m,lof) IF m>=lof THEN Raise(0) StrCopy(nstr,'') IF buf[m]="*" m:=m+1 co:=co+1 ELSE mmm:=m m,res:=scan_value(buf,m,nstr,lof) IF m=mmm m:=m+1 ELSE IF res=0 StrToLong(nstr,{xxx}) IF buf[m]="," m:=m+1 StrCopy(nstr,'') m,res:=scan_value(buf,m,nstr,lof) IF res=0 StrToLong(nstr,{yyy}) co:=co+1 obj:=objs[co] IF obj obj.setx(cs,xxx) obj.sety(cs,yyy) obj.setux(cs,xxx) obj.setuy(cs,yyy) ENDIF ELSE egerr() Raise(0) ENDIF ELSE egerr() Raise(0) ENDIF ENDIF ENDIF ENDIF IF ((buf[m]=13) OR (buf[m]=10)) THEN m:=lof+100 ENDWHILE RETURN co EXCEPT NOP ENDPROC -1 PROC retdepth(m) SELECT m CASE 0;RETURN 4 CASE 1;RETURN 4 CASE 2;RETURN 5 CASE 3;RETURN 6 CASE 4;RETURN 6 CASE 5;RETURN 7 CASE 6;RETURN 7 CASE 7;RETURN 7 CASE 8;RETURN 7 ENDSELECT ENDPROC 8 cbuf: LONG $90909090,$90909090,$90909090, $00000000,$00000000,$00000000, $FFFFFFFF,$FFFFFFFF,$FFFFFFFF, $40404040,$80808080,$A0A0A0A0, $80808080,$80808080,$80808080, $B0B0B0B0,$B0B0B0B0,$B0B0B0B0, $B0B0B0B0,$90909090,$A0A0A0A0, $FFFFFFFF,$A8A8A8A8,$98989898 PROC busy() IF win SetWindowPointerA(win,[WA_BUSYPOINTER,TRUE,WA_POINTERDELAY,TRUE,NIL,NIL]) ENDIF ENDPROC PROC ready() IF win SetWindowPointerA(win,[WA_BUSYPOINTER,FALSE,WA_POINTERDELAY,FALSE,NIL,NIL]) handme() ENDIF ENDPROC PROC reportmousemoves(win:PTR TO window) Forbid() win.flags:=win.flags OR WFLG_REPORTMOUSE Permit() ENDPROC PROC noreportmousemoves(win:PTR TO window);DEF flag Forbid() flag:=win.flags IF (flag AND WFLG_REPORTMOUSE) THEN flag:=flag-WFLG_REPORTMOUSE win.flags:=flag Permit() ENDPROC PROC handme() IF usehand=1 SetWindowPointerA(win,[WA_POINTER,hand1,WA_POINTERDELAY,FALSE,NIL,NIL]) ELSE ClearPointer(win) ENDIF ENDPROC PROC grabme() IF usehand=1 SetWindowPointerA(win,[WA_POINTER,hand2,WA_POINTERDELAY,FALSE,NIL,NIL]) ELSE IF usehand=2 SetWindowPointerA(win,[WA_POINTER,hand3,WA_POINTERDELAY,FALSE,NIL,NIL]) ELSE ClearPointer(win) ENDIF ENDIF ENDPROC PROC sysisize() IS IF scr.flags AND SCREENHIRES THEN SYSISIZE_MEDRES ELSE SYSISIZE_LOWRES PROC newimageobject(which) IS NewObjectA(NIL,'sysiclass', [SYSIA_DRAWINFO,dri,SYSIA_WHICH,which,SYSIA_SIZE,sysisize(),NIL]) PROC newpropobject(freedom,taglist) IS NewObjectA(NIL,'propgclass', [ICA_TARGET,ICTARGET_IDCMP,PGA_FREEDOM,freedom,PGA_NEWLOOK,TRUE, PGA_BORDERLESS,(dri.flags AND DRIF_NEWLOOK) AND (dri.depth<>1), TAG_MORE,taglist]) PROC newbuttonobject(image:PTR TO object,taglist) IS NewObjectA(NIL,'buttongclass', [ICA_TARGET,ICTARGET_IDCMP,GA_IMAGE,image,TAG_MORE,taglist]) /********************************************************************* *********** ********************************************** *********** I/O Stuff ********************************************** *********** ********************************************** *********************************************************************/ PROC seekcrlf(buf:PTR TO CHAR,mark,lof) WHILE ((buf[mark]<>13) AND (buf[mark]<>10) AND (mark<lof)) mark:=mark+1 ENDWHILE mark:=mark+1 IF ((buf[mark]=10) OR (buf[mark]=13)) THEN mark:=mark+1 ENDPROC mark PROC scan_value(buf:PTR TO CHAR,m,str,lof) DEF result=TRUE DEF mm,byte DEF dstr[10]:STRING StrCopy(dstr,'0',1) StrCopy(str,'') mm:=m byte:=buf[m] WHILE ((((byte>="0") AND (byte<="9")) OR (byte="-")) AND (m<lof)) PutChar(dstr,byte) StrAdd(str,dstr,1) m:=m+1 byte:=buf[m] ENDWHILE IF m<>mm mm:=m result:=FALSE ELSE result:=TRUE ENDIF ENDPROC mm,result PROC scan_nonspace(buf:PTR TO CHAR,m,lof) WHILE (((buf[m]=9) OR (buf[m]=" ")) AND (lof>m)) m:=m+1 ENDWHILE ENDPROC m PROC scan_string(buf:PTR TO CHAR,m,str,lof) DEF dstr[10]:STRING StrCopy(dstr,'0',1) WHILE ((buf[m]<>9) AND (buf[m]<>" ") AND (buf[m]<>13) AND (buf[m]<>10) AND lof>m) PutChar(dstr,buf[m]) StrAdd(str,dstr,1) m:=m+1 ENDWHILE ENDPROC m PROC egerr() DEF statusstr[500]:STRING StringF(statusstr,'?Syntax Error:Line #\d',linenum) setlistvlabels(gh,errlistv,-1) errlist.add(statusstr) setlistvlabels(gh,errlistv,errlist.head()) ENDPROC PROC err(msgptr) IF ((aslbase<>0)) EasyRequestArgs(win,[20,0,'Error!',msgptr,'Okay'],0,0) ELSE WriteF('\s\n',msgptr) ENDIF ENDPROC PROC aboutme() err('PlayFKiss is PUBLIC DOMAIN\nWritten in 1996 by\nChad Randall - crandall@msen.com\n\nPlease email suggestions,\nbug reports or KISS dolls!\n\nThanks for supporting the Amiga!') ENDPROC PROC stricmp(str1,str2,len) IS IF Strnicmp(str1,str2,len)=0 THEN TRUE ELSE FALSE PROC runevent(event,obj:PTR TO obj,cel:PTR TO cel) DEF ev=0,res=0 IF obj ev:=findeventtype(event,obj.number) IF ev runcommands(ev) res:=TRUE ENDIF ENDIF IF cel IF res=FALSE ev:=findeventtype(event,-1,cel.realname) IF ev runcommands(ev) res:=TRUE ENDIF ENDIF ENDIF IF ((res=FALSE) AND (obj=0) AND (cel=0)) ev:=findeventtype(event) IF ev runcommands(ev) res:=TRUE ENDIF ENDIF ENDPROC res /********************************************************************* *********** ********************************************* *********** LIST Stuff ********************************************* *********** ********************************************* *********************************************************************/ PROC alloccel() DEF cel:PTR TO cel DEF ordinal NEW cel.new() IF cel ordinal:=findemptycel() IF ordinal<>-1 cels[ordinal]:=cel ELSE END cel cel:=-1 ENDIF ELSE cel:=-1 ENDIF ENDPROC cel PROC allocobj(objn) DEF obj:PTR TO obj NEW obj.new(objn) IF obj IF objs[objn] END obj obj:=objs[objn] ELSE objs[objn]:=obj ENDIF ELSE obj:=-1 ENDIF ENDPROC obj PROC findemptycel() DEF i FOR i:=MAXCELS TO 0 STEP -1 IF cels[i]=0 THEN RETURN i ENDFOR ENDPROC -1 PROC countcels() DEF i,count=0 FOR i:=MAXCELS TO 0 STEP -1 IF cels[i] THEN count:=count+1 ENDFOR ENDPROC count PROC countobjs() DEF i,count=0 FOR i:=MAXOBJS TO 0 STEP -1 IF objs[i] THEN count:=count+1 ENDFOR ENDPROC count PROC freecels() DEF i FOR i:=MAXCELS TO 0 STEP -1 IF cels[i] freecel(cels[i]) cels[i]:=0 ENDIF ENDFOR ENDPROC PROC freeobjs() DEF i FOR i:=MAXOBJS TO 0 STEP -1 IF objs[i] freeobj(objs[i]) objs[i]:=0 ENDIF ENDFOR ENDPROC PROC freecel(cel:PTR TO cel) IF cel THEN END cel ENDPROC PROC freeobj(obj:PTR TO obj) IF obj THEN END obj ENDPROC /********************************************************************* *********** ********************************************** *********** OOP Stuff ********************************************** *********** ********************************************** *********************************************************************/ PROC new() OF listnodes IS newList(self.lh) PROC head() OF listnodes IS self.lh PROC end() OF listnodes DEF node:PTR TO ln DEF next=0 IF isempty(self)=0 node:=self.lh.head WHILE (node) next:=node.succ IF next Remove(node) DisposeLink(node.name) END node ENDIF node:=next ENDWHILE ENDIF ENDPROC PROC add(name) OF listnodes DEF node:PTR TO ln DEF str NEW node str:=String(StrLen(name)) StrCopy(str,name) node.name:=str AddTail(self.lh,node) ENDPROC node PROC end() OF obj ENDPROC PROC end() OF cel IF self.realname THEN DisposeLink(self.realname) IF self.comment THEN DisposeLink(self.comment) IF self.buf THEN Dispose(self.buf) IF self.obuf THEN Dispose(self.buf) self.dispose() ENDPROC PROC dispose() OF cel ENDPROC PROC realname(name) OF cel DEF str str:=String(StrLen(name)) StrCopy(str,name) IF self.realname THEN DisposeLink(self.realname) self.realname:=str ENDPROC PROC comment(name) OF cel DEF str str:=String(StrLen(name)) StrCopy(str,name) IF self.comment THEN DisposeLink(self.comment) self.comment:=str ENDPROC PROC setw(x) OF cel;self.w:=x;ENDPROC PROC seth(x) OF cel;self.h:=x;ENDPROC PROC setox(x) OF cel;self.ox:=x;ENDPROC PROC setoy(x) OF cel;self.oy:=x;ENDPROC PROC setpalette(x) OF cel;self.palet_num:=x;ENDPROC PROC setset(set,flag) OF cel;self.sets[set]:=flag;ENDPROC PROC setobj(x) OF cel;self.obj:=x;ENDPROC PROC new() OF cel self.mapped:=CMAP_SHOW ENDPROC PROC new(x) OF obj; self.number:=x;ENDPROC PROC setx(set,x) OF obj self.x[set]:=x ENDPROC PROC sety(set,y) OF obj self.y[set]:=y ENDPROC PROC setux(set,x) OF obj self.ux[set]:=x ENDPROC PROC setuy(set,y) OF obj self.uy[set]:=y ENDPROC PROC remember(set) OF obj self.lastx:=self.x[set] self.lasty:=self.y[set] self.rubx:=self.x[set] self.ruby:=self.y[set] ENDPROC PROC undo() OF obj DEF x,y x:=self.lastx;y:=self.lasty self.remember(curset) self.forcemove(x,y,TRUE) ENDPROC PROC forcemove(x,y,flag) OF obj IF (((self.x[curset]<>x) OR (self.y[curset]<>y)) OR (flag=TRUE)) IF flag THEN prechange() self.movequick(x,y) IF flag THEN postchange() ENDIF ENDPROC PROC move(x,y,flag) OF obj DEF nx,ny,dif IF (self.fix>0) dif:=limit(6-self.fix,0,5) nx:=limit(x,self.rubx-dif,self.rubx+dif) ny:=limit(y,self.ruby-dif,self.ruby+dif) ELSE nx:=x;ny:=y ENDIF self.forcemove(nx,ny,flag) ENDPROC PROC movequick(x,y) OF obj DEF cel:PTR TO cel DEF obj:PTR TO obj DEF i IF usebounds x:=bigger(0,smaller(x,envw-self.width())) y:=bigger(0,smaller(y,envh-self.height())) ENDIF FOR i:=0 TO MAXCELS cel:=cels[i] IF cel IF (cel.obj>=0) obj:=objs[cel.obj] IF (obj) IF (obj=self) IF cel.mapped<>CMAP_HIDE orcel(cel,obj,TRUE) ENDIF ENDIF ENDIF ENDIF ENDIF ENDFOR self.setx(curset,x) self.sety(curset,y) FOR i:=0 TO MAXCELS cel:=cels[i] IF cel IF (cel.obj>=0) obj:=objs[cel.obj] IF (obj) IF (obj=self) IF cel.mapped<>CMAP_HIDE orcel(cel,obj,TRUE) ENDIF ENDIF ENDIF ENDIF ENDIF ENDFOR ENDPROC PROC width() OF obj DEF w=0,i,cel:PTR TO cel FOR i:=0 TO MAXCELS cel:=cels[i] IF cel IF cel.obj=self.number w:=bigger(w,cel.ox+cel.w) ENDIF ENDIF ENDFOR ENDPROC w PROC height() OF obj DEF h=0,i,cel:PTR TO cel FOR i:=0 TO MAXCELS cel:=cels[i] IF cel IF cel.obj=self.number h:=bigger(h,cel.oy+cel.h) ENDIF ENDIF ENDFOR ENDPROC h PROC recolor() OF cel DEF y,a=0,w w:=(self.w*self.h) IF ((usewb<>0) OR (onwb<>0)) IF self.obuf=0 self.obuf:=New((self.w*self.h)+64) CopyMem(self.buf,self.obuf,(self.w*self.h)) ENDIF ENDIF FOR y:=1 TO w self.buf[a]:=apens[self.obuf[a]] a:=a+1 ENDFOR ENDPROC PROC load(dir) OF cel HANDLE DEF name[500]:STRING DEF w=-1,h=-1,x,y DEF fh=0 DEF fib=0:PTR TO fileinfoblock DEF lock=0 DEF buf=0:PTR TO CHAR DEF nbuf=0:PTR TO CHAR DEF tbuf=0:PTR TO CHAR DEF p1:PTR TO CHAR,p2:PTR TO CHAR DEF leftedge=0 -> DEF xfib:PTR TO xpkfib DEF xbuf=0,xbuflen=0 -> NEW xfib tbuf:=FastNew(10) StrCopy(name,dir) eaddpart(name,self.realname,490) IF self.buf THEN Dispose(self.buf);self.buf:=0 IF self.obuf THEN Dispose(self.obuf);self.obuf:=0 IF (fib:=AllocDosObject(DOS_FIB,0))=0 THEN Raise("err") IF (lock:=Lock(name,SHARED_LOCK))=0 THEN Raise("file") Examine(lock,fib) IF (fh:=Open(name,MODE_OLDFILE))=0 THEN Raise("file") IF xpkbase Read(fh,tbuf,4) Seek(fh,0,OFFSET_BEGINNING) IF ((tbuf[0]="X") AND (tbuf[1]="P") AND (tbuf[2]="K")) XpkUnpack([XPK_INNAME,name,XPK_GETOUTBUF,{xbuf},XPK_GETOUTBUFLEN,{xbuflen},TAG_END]:LONG) IF ((xbuf<>0) AND (xbuflen>0)) IF (buf:=New(xbuflen+32)) CopyMem(xbuf,buf,xbuflen) fib.size:=xbuflen-XPK_MARGIN ENDIF FreeMem(xbuf,xbuflen) IF buf=0 THEN Raise("MEM") ELSE IF (buf:=New(fib.size+32))=0 THEN Raise("MEM") Read(fh,buf,fib.size) ENDIF ELSE IF (buf:=New(fib.size+32))=0 THEN Raise("MEM") Read(fh,buf,fib.size) ENDIF ELSE IF (buf:=New(fib.size+32))=0 THEN Raise("MEM") Read(fh,buf,fib.size) ENDIF IF Long(buf)="KiSS" IF (buf[4]=FILE_MARK_CELL) self.setw(buf[9]*256+buf[8]) self.seth(buf[11]*256+buf[10]) self.setox(buf[13]*256+buf[12]) self.setoy(buf[15]*256+buf[14]) self.bit_per_pixel:=buf[5] nbuf:=buf+32 ENDIF ELSE self.setw(buf[1]*256+buf[0]) self.seth(buf[3]*256+buf[2]) self.setox(0) self.setoy(0) self.bit_per_pixel:=4 w:=self.w h:=self.h IF ((w/2)<>(w+1/2)) THEN w:=w+1 w:=w/2 IF (((w*h)+4)=fib.size) nbuf:=buf+4 ELSE ENDIF ENDIF IF nbuf IF self.bit_per_pixel=4 self.w:=((self.w+1)/2)*2 leftedge:=TRUE ENDIF w:=self.w h:=self.h self.buf:=New((w*h)+64) IF usewb THEN self.obuf:=New((w*h)+64) IF (self.buf) IF self.bit_per_pixel=4 p1:=nbuf p2:=self.buf FOR x:=0 TO self.h-1 FOR y:=0 TO self.w-1 STEP 2 p2[0]:=(p1[0] AND $F0/$10) IF p2[0]>0 THEN p2[0]:=p2[0]+(16*self.palet_num) p2[1]:=(p1[0] AND $F) IF p2[1]>0 THEN p2[1]:=p2[1]+(16*self.palet_num) p1:=p1+1 p2:=p2+2 ENDFOR ENDFOR IF leftedge /* FOR y:=0 TO self.h-1 p2:=self.buf+(self.w*y) p2[self.w-1]:=0 ENDFOR */ ENDIF ELSE CopyMem(nbuf,self.buf,w*h) IF self.palet_num>0 p2:=self.buf FOR y:=self.buf TO self.buf+(w*h)-1 IF p2[y]>0 p2[y]:=(p2[y]+(16*self.palet_num)) ENDIF ENDFOR ENDIF ENDIF IF usewb THEN CopyMem(self.buf,self.obuf,(w*h)) ELSE w:=-1 ENDIF ENDIF EXCEPT DO -> END xfib IF tbuf THEN FastDispose(tbuf,10) IF fib THEN FreeDosObject(DOS_FIB,fib) IF lock THEN UnLock(lock) IF buf THEN Dispose(buf) IF fh THEN Close(fh) ENDPROC w,h PROC setfix(val) OF obj DEF ev=0 IF ((val=0) AND (self.fix>0)) IF (runevent(EV_UNFIX,self,0)) THEN catchobj:=self ENDIF self.fix:=bigger(val,0) ENDPROC PROC countmembers() OF obj DEF cel:PTR TO cel,i,mem=0 FOR i:=0 TO MAXCELS cel:=cels[i] IF cel IF self.number=cel.obj mem:=mem+1 ENDIF ENDIF ENDFOR ENDPROC mem hand1dataa: INT $0000,$6000,$7000,$781C,$3CEE,$1EF6,$0F7E,$07FE INT $03FE,$01FC,$01FA,$0EFE,$1FDC,$1838,$0000 hand1datab: INT $6000,$9000,$E81C,$B4EA,$5BD5,$2DEB,$16BF,$0BFB INT $05FB,$03BE,$0FDF,$11FD,$2FBA,$37FC,$3878 hand2dataa: INT $0000,$0000,$0000,$001C,$00EE,$06F6,$077E,$07FE INT $0BFE,$0DFC,$0DFA,$06FE,$07DC,$0038,$0000 hand2datab: INT $0000,$0000,$001C,$00EA,$07D5,$0DEB,$0EBF,$1BFB INT $15FB,$1BBE,$17DF,$0FFD,$0BBA,$07FC,$0078 hand3dataa: LONG %10000000000000000000000000000000 LONG %00000000000000000000000000000000 hand3datab: LONG %10000000000000000000000000000000 LONG %00000000000000000000000000000000 hand4dataa: INT $07C0,$1FF0,$3FF8,$7FFC,$7CFC,$F9FE,$F3FE,$F7DE INT $FF9E,$FF3E,$7E7C,$7FFC,$3FF8,$1FF0,$07C0 hand4datab: INT $07C0,$1830,$2008,$4384,$4484,$8902,$9232,$9452 INT $9892,$8122,$4244,$4384,$2008,$1830,$07C0 PROC min_size(fh) OF pi_gauge DEF w,h h:=fh+4 w:=10*StrLen(self.string) ENDPROC w,h PROC new(string) OF pi_gauge self.string:=String(StrLen(string)) StrCopy(self.string,string) ENDPROC PROC end() OF pi_gauge IF self.string THEN DisposeLink(self.string) ENDPROC PROC draw(win:PTR TO window) OF pi_gauge DEF drawinfo:PTR TO drawinfo DEF visual=0,scr=0 DEF newx,w,h IF win scr:=win.wscreen IF scr visual:=GetVisualInfoA(scr,NIL) IF visual drawinfo:=GetScreenDrawInfo(win.wscreen) IF drawinfo IF self.curlevel>0 IF ((self.top-self.curlevel)>0) newx:=(((self.w-7)*100)/(10000/(bigger((self.curlevel*100/(self.top)),1)))) drawbevelbox(visual,win.rport,self.x,self.y,self.w,self.h,1,TRUE,-1) SetDrMd(win.rport,RP_JAM2) SetAPen(win.rport,drawinfo.pens[FILLPEN]) RectFill(win.rport,self.x+3,self.y+2,self.x+newx+3,self.y+self.h-3) ENDIF ENDIF IF (self.string) IF self.curlevel=0 drawbevelbox(visual,win.rport,self.x,self.y,self.w,self.h,1,TRUE,0) ENDIF w,h:=fontsize2(win.rport,self.string,drawinfo.font,0) SetFont(win.rport,drawinfo.font) SetDrMd(win.rport,RP_JAM1) Move(win.rport,self.x+((self.w)/2)-(w/2),self.y+drawinfo.font.baseline+1) SetAPen(win.rport,drawinfo.pens[TEXTPEN]) Text(win.rport,self.string,StrLen(self.string)) ENDIF FreeScreenDrawInfo(scr,drawinfo) ENDIF FreeVisualInfo(visual) ENDIF ENDIF ENDIF ENDPROC PROC render(x,y,xs,ys,win:PTR TO window) OF pi_gauge self.x:=x self.y:=y self.w:=xs self.h:=ys self.draw(win) ENDPROC PROC will_resize() OF pi_gauge IS RESIZEX PROC text(string) OF pi_gauge IF gh IF self.string DisposeLink(self.string) self.string:=String(StrLen(string)) StrCopy(self.string,string) ENDIF self.draw(gh.wnd) ENDIF ENDPROC PROC setlevel(val,top) OF pi_gauge self.curlevel:=smaller(val,top-2) self.top:=bigger(top,1) IF gh self.draw(gh.wnd) ENDIF ENDPROC PROC dearc(file,type) DEF a=0,l,rxdirname[500]:STRING,rxcommand[1000]:STRING DEF stat,result2 pppp.text('Uncompressing Kiss set...') Forbid() REPEAT INC a StringF(rexxname,'PlayFKISS.\d',a) UNTIL (FindPort(rexxname)=0) rexxport,rexxsigbit:=createPort(rexxname,0) rexxsigbit:=Shl(1,rexxsigbit) Permit() a:=0 REPEAT StringF(rxdirname,'t:pkt\d',a) l:=CreateDir(rxdirname) a:=a+1 UNTIL l UnLock(l) IF type=0 StringF(rxcommand,'"ADDRESS COMMAND ''lha e -m \s >NIL: <NIL: \s/''"',file,rxdirname) ELSE StringF(rxcommand,'"ADDRESS COMMAND ''lzx x -m \s >NIL: <NIL: \s/''"',file,rxdirname) ENDIF sendRexxMsg('REXX',rxcommand,0,RXFB_STRING,rexxport,rexxname,0) a:=0 WHILE (unconfirmed>0) AND (a<100) REPEAT rexxhand,stat,result2:=handleRexxMsg(rexxport) IF (rexxhand) replyRexxMsg(rexxhand) IF unconfirmed=0 THEN a:=100 ENDIF Delay(25) a:=a+1 IF stat=RXTYPE_REPLY IF (rexxhand) THEN rexxerror(rexxhand,result2) ENDIF l:=(a AND %11) SELECT l CASE 0;pppp.text('Uncompressing Kiss set... |') CASE 1;pppp.text('Uncompressing Kiss set... /') CASE 2;pppp.text('Uncompressing Kiss set... -') CASE 3;pppp.text('Uncompressing Kiss set... \\') ENDSELECT UNTIL ((stat=RXTYPE_NOMSG) OR (a>100)) ENDWHILE IF unconfirmed>0 THEN err('REXX command failed!') StrCopy(oldafile,afname) StrCopy(afname,rxdirname) discovercnffile() deletePort(rexxport) ENDPROC PROC discovercnffile() DEF error,first=0 DEF apath=NIL:PTR TO anchorpath DEF fileinfo=NIL:PTR TO fileinfoblock DEF achain=NIL:PTR TO achain DEF names[20]:LIST DEF i,count=0 DEF pat[500]:STRING StrCopy(pat,afname) eaddpart(pat,'#?.cnf',490) FOR i:=0 TO 19;names[i]:=String(20);ENDFOR count:=0 NEW apath error:=NIL WHILE error=NIL IF (first=FALSE) error:=MatchFirst(pat,apath) first:=TRUE ELSE error:=MatchNext(apath) ENDIF IF (error=NIL) achain:=apath.last IF (achain) fileinfo:=achain.info IF (fileinfo) IF (fileinfo.direntrytype)<0 StrCopy(names[count],fileinfo.filename) count:=smaller(count+1,19) ENDIF ENDIF ENDIF ENDIF ENDWHILE END apath IF count>0 IF count=1 eaddpart(afname,names[0],490) ELSE StrCopy(pat,names[0]) FOR i:=1 TO count-1 StrAdd(pat,'|') StrAdd(pat,names[i]) ENDFOR i:=EasyRequestArgs(win,[20,0,'Pick a .cnf file.','Choose which .cnf file:',pat],0,0) eaddpart(afname,names[i],490) ENDIF ELSE err('Could not find any .cnf files in archive.') ENDIF FOR i:=0 TO 19;DisposeLink(names[i]);ENDFOR ENDPROC PROC rexxerror(level,errnum) DEF body[4000]:STRING DEF errptr:PTR TO nexxstr /* ErrorMsg() is not documented (becuase it returns a code in A0 ??) */ MOVE.L rexxsysbase,A6 MOVE.L errnum,D0 JSR -96(A6) /* ErrorMsg() */ MOVE.L A0,errptr StringF(body,'An AREXX error occured while dearcing.\n\nError Level: \d\nError \d: \s',level,errnum,errptr.buff) err(body) ENDPROC PROC cleanuparc() DEF d[500]:STRING,f[500]:STRING DEF error,first=0 DEF apath=NIL:PTR TO anchorpath DEF fileinfo=NIL:PTR TO fileinfoblock DEF achain=NIL:PTR TO achain DEF pat[500]:STRING splitname(afname,d,f) IF stricmp(d,'t:pkt',5) pppp.text('Deleting temp files...') StrCopy(pat,d) eaddpart(pat,'#?',490) error:=NIL NEW apath WHILE error=NIL IF (first=FALSE) error:=MatchFirst(pat,apath) first:=TRUE ELSE error:=MatchNext(apath) ENDIF IF (error=NIL) achain:=apath.last IF (achain) fileinfo:=achain.info IF (fileinfo) IF (fileinfo.direntrytype)<0 StrCopy(f,d) eaddpart(f,fileinfo.filename,490) DeleteFile(f) ENDIF ENDIF ENDIF ENDIF ENDWHILE END apath DeleteFile(d) StrCopy(afname,ofilename) ENDIF ENDPROC